sheet1から抽出しsheet2へコピーをVBAで

質問

VBA初心者です。色々本など見たのですがどうして良いか判らず質問させて頂きます。

sheet2のA1にデータを入力したら、sheet1のA列に同じデータがあるかどうか探してある場合は、その行をsheet2の6行目からコピーをさせたいのですが、
(1)sheet1のデータは下に追加していきます。
(2)sheet2のデータ貼り付けは詰めて貼り付けていきたい。

sheet1

　A　　　B　　　　C
1　－　　－　　　－　　
2　－　　－　　　－
3　－　　－　　　－　　　
4　社名　商品名　入荷数
5　A社 　　　○ 　　　10
6　B社 　　　△ 　　　5
7　C社 　　　■ 　　　20
8　A社 　　　× 　　　30
9　D社 　　　○ 　　　10　
・ ・ 　　・ 　　　・
・ ・ 　　・ 　　　・
・ ・ 　　・ 　　　・

sheet2

　A　　　B　　　　C　　　
1　A社　　－　　　－　
2　－ 　　－　　　－　
3　－ 　　－　　　－　
4　－ 　　－　　　－　
5　社名　商品名　入荷数
6　A社 　　　○ 　　　10
7　A社 　　　× 　　　30
・ ・ 　　・ 　　　・
・ ・ 　　・ 　　　・
・ ・ 　　・ 　　　・
-はブランクセル

色々試したのですが、sheet2にコピーはされてもブランクの行が詰まらないなど上手くいかないため教えて頂きたく質問させて頂きました。
宜しくお願いいたします。

回答No.3

imogasi

この質問は、こうなってほしいという、結果は書いてあるが
どういうキッカケにSheet2へのデータ追加を行うかの、観点が脱落している。
イベントという仕組みを使うのだろうが、これを勉強しましたか。
バッチ処理といって、夕方仕事が終ってから、Sheet2への転記をやるという形態もあるのだ。
ーー
＞sheet2のA1にデータを入力したら、
とあるからSheet2のChangeイベントを使うのだろう。
＞その行をsheet2の6行目からコピーをさせたいのですが
下記ではkでコントロールしている。初期値ｋ＝６
ーー
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Worksheets ("Sheet2"), Range("A5:C500").Clear
d1 = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
'MsgBox d1
s = Worksheets("Sheet2").Range("A1")
'ここへSheet2の社名　商品名　入荷数の文字列セットを入れる（ここでは略）
k = 6
For i = 5 To d1
If Worksheets("Sheet1").Cells(i, "A") = s Then
Worksheets("Sheet2").Cells(k, "A") = Worksheets("Sheet1").Cells(i, "A")
Worksheets("Sheet2").Cells(k, "B") = Worksheets("Sheet1").Cells(i, "B")
Worksheets("Sheet2").Cells(k, "C") = Worksheets("Sheet1").Cells(i, "C")
k = k + 1
End If
Next i
End If
End Sub

回答No.2

okormazd

ANo.1
です。

withが生きてなかった。

Sub copy1to2()

With Sheets(2)
r11 = 5
r12 = Sheets(1).Cells(65536, 1).End(xlUp).Row
c1 = 1

r2 = .Cells(65536, 1).End(xlUp).Row + 1
c2 = 1

For r1 = r11 To r12
If sya = Sheets(1).Cells(r1, c1) Then
.Cells(r2, c2) = sya
.Cells(r2, c2 + 1) = Sheets(1).Cells(r1, c1 + 1)
.Cells(r2, c2 + 2) = Sheets(1).Cells(r1, c1 + 2)
r2 = r2 + 1
End If
Next
End With

End Sub

回答No.1

okormazd

ちょっと変なのだが。

sheet2のA1にデータを入力したら、sheet1のA列に同じデータがあるかどうか探してある場合は、その行をsheet2の6行目からコピー

sheet1のデータは下に追加していきます。

だと、sheet2のA1にデータを入力したときに、sheet1からsheet2へコピーするんだが、あとでsheet1に追加したデータはそのままだ。

ここは、sheet1に入力したときに該当するsheetにコピーするようにしたほうがいいと思うが。

質問のままのコードは下記。

Sheet(2)のコード

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Address = "$A$1" Then
sya = Target
copy1to2
End If

End Sub

標準モジュールのコード

Public sya

Sub copy1to2()

With Sheets(2)
r11 = 5
r12 = Sheets(1).Cells(65536, 1).End(xlUp).Row
c1 = 1

r2 = Sheets(2).Cells(65536, 1).End(xlUp).Row + 1
c2 = 1

For r1 = r11 To r12
If sya = Sheets(1).Cells(r1, c1) Then
Sheets(2).Cells(r2, c2) = sya
Sheets(2).Cells(r2, c2 + 1) = Sheets(1).Cells(r1, c1 + 1)
Sheets(2).Cells(r2, c2 + 2) = Sheets(1).Cells(r1, c1 + 2)
r2 = r2 + 1
End If
Next
End With

End Sub