こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

VBA 別シートの最終行に追記

ExcelのSheet1で作成した表の一部項目を、Sheet2に一覧表としてまとめたいのです。

例えばSheet1にアンケート項目のような入力されていて、毎日使いまわします。
セルA1: 訪問日→固定     セルB1: (日付)→更新
セルA3: お客様指名→固定  セルB3: (氏名)→更新
使いまわすので、1度入力されたものは、Sheet2に一覧表として転記しておきたいのです。Sheet2の一覧表の最終行をみつけて追記していきたいです。
書いてみたのは以下の通り。

Private Sub 登録ボタン_Click()

Dim SH1 As Worksheet, SH2 As Worksheet
Dim GYO As Long

Set SH1 = ThisWorkbook.Worksheets("回答内容")
Set SH2 = ThisWorkbook.Worksheets("情報シート")

' Sheet2の最終行を取得
GYO = SH2.Range("$A$65536").End(xlUp).Row
' 最終行の次行を取得
If SH2.Cells(GYO, 1).Value <> "" Then GYO = GYO + 1
 ' 現在の収容位置の下に転記
SH2.Cells(GYO, 1).Resize(1, 20).Value = SH1.Range("$c$2:$D$10").Value

With SH1
.Range("A3").Copy Destination:=SH2.Range("A2")
.Range("B3").Copy Destination:=SH2.Range("B2")
End With
End Sub

項目は飛び飛びのセルに入力されていて、それらをまとめて一覧表の1行にまとめたいと思っています。
ここでは例としてSheet1[A3][B3]セルをSheet2へ転記していますが、項目はもっといっぱいあります。
記載したコードで実行すると、1回目は転記されますが、2回目以降が追記されていきません。
' 現在の収容位置の下に転記
のところに問題があると思っています。

全くの初心者が、コードを書くのには無理があると思いますが、どなたか教えていただけないでしょうか。宜しくお願いします。

投稿日時 - 2009-04-06 13:17:16

QNo.4857143

すぐに回答ほしいです

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.2

>記載したコードで実行すると、1回目は転記されますが、2回目以降が追記されていきません。
 私は1回目もおかしいと存じますが。。。

>' 現在の収容位置の下に転記
以下が、例えば

SH2.Cells(GYO, 3).Resize(1, 9).Value = Application.Transpose(SH1.Range("$c$2:$C$10").Value)
SH2.Cells(GYO, 12).Resize(1, 9).Value = Application.Transpose(SH1.Range("$D$2:$D$10").Value)
With SH1
.Range("A3:B3").Copy Destination:=SH2.Cells(GYO, 1).Resize(, 2)
End With

ということなら、何となく解りますが。。。


>項目は飛び飛びのセルに入力されていて、それらをまとめて一覧表の1行にまとめたい
のでしたら、例えば、
>' 現在の収容位置の下に転記
以下を

Dim myCells As Variant, i As Byte
myCells = Split("A3 B3 C2 C3 C4 C5 C6 C7 C8 C9 C10 D2 D3 D4 D5 D6 D7 D8 D9 D10")
For i = 0 To 19
SH2.Cells(GYO, i + 1).Value = SH1.Range(myCells(i)).Value
Next

のようにに変えてみられてはいかがでしょうか?

投稿日時 - 2009-04-06 14:53:27

お礼

最終的には下記の記述で正常に動くようになりました!。
-------------------------------------------------------------
Private Sub 登録ボタン_Click()
 Dim SH1 As Worksheet, SH2 As Worksheet
 Dim GYO As Long
 Dim copydata()
Set SH1 = ThisWorkbook.Worksheets("回答内容")
Set SH2 = ThisWorkbook.Worksheets("情報シート")
' 転記先Sheet2の最終行を取得
GYO = SH2.Range("A65536").End(xlUp).Offset(1).Row
' 最終行の次行を取得
If SH2.Cells(GYO, 1).Value <> "" Then GYO = GYO + 1
  ' 転記するデータを取得
  copydata = SH1.Range("Z1").Resize(100, 1).Value
  ' 現在の収容位置の下に転記(行列入替)
  copydata = WorksheetFunction.Transpose(copydata)
 SH2.Cells(GYO, 1).Resize(1, 100).Value = copydata
End Sub
-------------------------------------------------------------

投稿日時 - 2009-04-13 12:06:31

ANo.1

>ここでは例としてSheet1[A3][B3]セルをSheet2へ転記していますが、項目はもっといっぱいあります。
例題に対して回答をもらい応用できるのなら問題ないですけど、そうではなければ
初めから具体的に質問された方が宜しいかも。

>SH2.Cells(GYO, 1).Resize(1, 20).Value = SH1.Range("$c$2:$D$10").Value
左辺と右辺でのセル範囲って違いますよね?

蛇足でしたらごめんなさい。

投稿日時 - 2009-04-06 14:22:24

お礼

アドバイスありがとうございます。
左辺と右辺はご指摘の通り、違います。
「SH2.Cells(GYO, 1).Resize(1, 20).Value = SH1.Range("$c$2:$D$10").Value」
自分でもよくわからず書いてしまいましたが、やりたいことが、Sheet1の非連続セルのデータ(具体的にセルB1とB3のみ対象)を、Sheet2に一覧(1行)に転記したかったので。
書くとすれば、
>SH2.Cells(GYO, 1).Resize(1, 20).Value = SH1.Range("$A$1:$B$3").Value
と書けたかもしれませんが、これだとRangeの後に書いたセルのデータが、B1の同じデータのみ横に20列も入力されてしまいました。

投稿日時 - 2009-04-06 15:45:04

あなたにオススメの質問