Microsoftマイクロソフトのエクセルでマクロ

質問

MicrosoftマイクロソフトのエクセルでマクロVBAをやりたいです。 プログラムがちょっとわかりません。

sheet1、sheet2、sheet3を参照します。各sheetの中は写真のようなデータが入ってます。
sheet1から始めます。
列Aの3行から23行までをみます。
◯が書いてあったら、その行をsheet4に貼り付けます。
順次、23行まで繰り返します。
次のsheet2も同じ事を繰り返します。
次のsheet3も同じ事を繰り返します。
sheet4に◯が書かれた行の一覧が出来れば成功です。
可能でしょうか？
出来れば、モジュールmoduleに貼り付けるだけで終わるようにプログラム教えてもらえますか？

回答No.2

kkkkkm · ベストアンサー

No1の追加です。

モジュールのコードを記載する画面の一番上に
Option Base 1
を追加してください。

お礼

ありがとうございます。出来ました。

回答No.4

imogasi

これこそ丸投げの質問で、まる写しを希望しているが、もう少し本なり、WEBの例題を調べて、勉強して、行き詰まった点に絞って質問すべきだ。
適した一部の人を除いて、例えスクリプトでもプログラムの独学は時間がかかり難しいと思う。そっくりのコードを書いてくれでは、進歩しないと思う。
ーー
それに添付画像がぼやけて読みにくい。回答者は、テストデータで自分のコードをテストして、確認すると思うが、そのテストデータ作りを回答者にやれというのは手数がかかる。
下記のような質問の書き方を参考にしてみて。
ーー
例示するのは、シート数は複数の場合２，３シートで済むし、行数も４－５行程度あれば済むことが多い。
ーー
テストデータ（セルにコピー貼り付けして、データー区切り位置でセルにバラける）
Sheet1　A-D列
1a x1 x1
○ 2a x2 x2
3a x3 x3
4a x4 x4
5a x5 x5
○ 6a x6 x6
7a x7 x7
8a x8 x8
Sheet2　A-D列
１ｂ xb1 xb1
○ ２ｂ xb2 xb2
３ｂ xb3 xb3
４ｂ xb4 xb4
○ ５ｂ xb5 xb5
６ｂ xb6 xb6
７ｂ xb7 xb7
○ ８ｂ xb8 xb8
Sheet3　A-D列
○ １ｃ XC1 XC1
２ｃ XC2 XC2
３ｃ XC3 XC3
○ ４ｃ XC4 XC4
５ｃ XC5 XC5
６ｃ XC6 XC6
７ｃ XC7 XC7
○ ８ｃ XC8 XC8
標準モジュールに
Sub test01()
Set sh4 = Worksheets("Sheet4") '集約シート
j = 2　’Sheet4での行番号ポインタ,初期設定
For Each sh In Worksheets
If sh.Name <> sh4.Name Then '処理対象にしない
’MsgBox sh.Name
For i = 3 To 23
If sh.Cells(i, "A") = "○" Then
’ MsgBox i
' sh4.Range(Cells(j, "A"), Cells(j, "C")) = sh.Range(sh.Cells(i, "B"), sh.Cells(i, "D"))
'個別セル代入法
　　　　 'sh4.Cells(j, "A") = sh.Cells(i, "B")
　　　　'sh4.Cells(j, "A") = sh.Cells(i, "C")
　　　　'sh4.Cells(j, "A") = sh.Cells(i, "D")
' コピー貼り付け法
'sh.Range(sh.Cells(i, "B"), sh.Cells(i, "D")).Copy sh4.Cells(j, "A")
' 一旦配列に代入法
c = sh.Range(sh.Cells(i, "B"), sh.Cells(i, "D"))
sh4.Range(Cells(j, "A"), Cells(j, "C")) = c
j = j + 1

End If
Next i
End If
Next
End Sub
ーー
結果
Shee4
2a x2 x2
6a x6 x6
２ｂ xb2 xb2
５ｂ xb5 xb5
８ｂ xb8 xb8
１ｃ XC1 XC1
４ｃ XC4 XC4
８ｃ XC8 XC8
すでに配列に入れる方法が回答があるようだが
FOR　 EACH法もあり便利な点もある。　何が便利か勉強のこと。
ーー
該当データをSheet4に移すとき
（１）Copy・貼り付け法
（２）項目(=列）の各セルを列挙法
（３）ヴァリアント配列法
などがある。この考えは今後、役に立つと思う。
ーーー
手を抜いているが、上記コードで不適当な点がある。何か考えてみて。

回答No.3

Prome_Lin

Option Explicit
Sub Test()
Dim s, t As Sheets
Dim i, j, k, l As Integer
l = 0
For i = 1 To 3
Set s = ThisWorkbook.Worksheets(i)
For j = 3 To 23
If s.Cells(j, 1).Value = "○" Then
l = l + 1
For k = 4 To 6
ThisWorkbook.Worksheets(4).Cells(l, k).Value = s.Cells(j, k).Value
Next k
End If
Next j
Set s = Nothing
Next i
End Sub

３つのシートを調べるので「For i = 1 to 3」としています。

調べるシートを「Set」しています（このとき、シートの名前は何でも構いません。左端から、順番に１、２、３となります）。

それぞれのシートの３行目から２３行目まで調べます。

「Ａ」列に「○」があれば、「Ｄ」列から「Ｆ」列を４番目のシートにコピーします。

以上です。

回答No.1

kkkkkm

こちらを貼り付けて実行　シート名Sheet1などは実際のシート名に変更してください。
Sub Example()
Dim sh(4) As Worksheet
Dim i As Long, j As Long, k As Long

Set sh(1) = Worksheets("Sheet1")
Set sh(2) = Worksheets("Sheet2")
Set sh(3) = Worksheets("Sheet3")
Set sh(4) = Worksheets("Sheet4")

k = sh(4).Cells(Rows.Count, "A").End(xlUp).Row + 1
If k < 3 Then
k = 3
End If
For i = 1 To 3
For j = 3 To 23
If sh(i).Cells(j, "A") = "◯" Then
' sh(i).Cells(j, "A").Resize(1, 6).Copy sh(4).Cells(k, "A").Resize(1, 6)
' 書式の設定も移したい場合には↑左端の'を消し↓の左端に'を入れる
sh(4).Cells(k, "A").Resize(1, 6).Value = sh(i).Cells(j, "A").Resize(1, 6).Value
' データだけで移す↑
k = k + 1
End If
Next j
Next i
For i = 1 To 4
Set sh(i) = Nothing
Next i
End Sub