Excelのループの使い方がわかりません

質問

使用しているエクセルのバージョンは2003です。
ファイル名がa～xまであるcsvファイルを順番に開いて特定の範囲をコピーして
別のエクセルブックの特定の範囲に張り付ける作業をVBAを使って組みたいのですが
いまいち分りません。ご指導のほどよろしくお願いします。
WS1は別のエクセルブックを指しています。

Workbooks.Open "a.csv"
Worksheets(a).Range("B2:O3").Copy WS1.Range("F7:S8")
Worksheets(a).Range("B4:O5").Copy WS1.Range("F10:S11")
Worksheets(a).Range("B6:O7").Copy WS1.Range("F13:S14")
Worksheets(a).Range("B8:O10").Copy WS1.Range("F16:S18")
Windows("a.csv").Activate
ActiveWindow.Close

Workbooks.Open "b.csv"
Worksheets(b).Range("B2:O3").Copy WS1.Range("F21:S22")
Worksheets(b).Range("B4:O5").Copy WS1.Range("F24:S25")
Worksheets(b).Range("B6:O7").Copy WS1.Range("F27:S28")
Worksheets(b).Range("B8:O10").Copy WS1.Range("F30:S32")
Windows("b.csv").Activate
ActiveWindow.Close

Workbooks.Open "c.csv"
Worksheets(c).Range("B2:O3").Copy WS1.Range("F35:S36")
Worksheets(c).Range("B4:O5").Copy WS1.Range("F38:S39")
Worksheets(c).Range("B6:O7").Copy WS1.Range("F41:S42")
Worksheets(c).Range("B8:O10").Copy WS1.Range("F44:S46")
Windows("c.csv").Activate
ActiveWindow.Close

Workbooks.Open "d.csv"
Worksheets(d).Range("B2:O3").Copy WS1.Range("F49:S50")
Worksheets(d).Range("B4:O5").Copy WS1.Range("F52:S53")
Worksheets(d).Range("B6:O7").Copy WS1.Range("F55:S56")
Worksheets(d).Range("B8:O10").Copy WS1.Range("F58:S60")
Windows("d.csv").Activate
ActiveWindow.Close
これがファイルxまで続きます。

回答No.1

ham_kamo · ベストアンサー

コピー元のセルが一定で、コピー先のセルも規則性があるので、Forループでまわしてみました。以下にサンプルソースを掲載します。
★注意
　FileName = Array("a", "b", "c")
は、csvファイルのファイル名（.csv抜き）を羅列してください。
（本当のファイル名はa,b,cではないと思いますが、ファイル名に規則性があれば、さらに効率的な書き方ができるでしょう）

WS1というのは質問文のマクロで定義されてないので、
　Workbooks.Open "Book2.xls"
　Set WS1 = Workbooks("Book2.xls").Worksheets("Sheet1")
と勝手に名前をつけてオープンしています。この処理に至るまでにWS1は定義されていると思うので、ここはカットしてください。

Sub CSV読み込み()
　On Error Resume Next
　Dim FileName As Variant
　Dim i As Integer, j As Integer
　Dim BookName As String
　Dim WS1 As Worksheet
　FileName = Array("a", "b", "c")

　Application.ScreenUpdating = False

　Workbooks.Open "Book2.xls"
　Set WS1 = Workbooks("Book2.xls").Worksheets("Sheet1")

　For i = 0 To UBound(FileName)
　　BookName = FileName(i) & ".csv"
　　Workbooks.Open BookName
　　With Workbooks(BookName)
　　　For j = 0 To 3
　　　　Worksheets(1).Cells(j * 2 + 2, "B").Resize(2, 14).Copy _
　　　　WS1.Cells(i * 14 + 7 + j * 3, "F")
　　　Next
　　　.Close
　　End With
　Next

　Application.ScreenUpdating = True
End Sub

回答No.2

shinyat1

参考になれば・・・シートにファイルをドラッグ＆ドロップするとコピーするマクロです。
A2セルからAAの最下行までをマクロブックに追加します。
CSV確認用固定文字は、ファイル確認するため、B1セルに入っている値を確認しているだけですので、いらないかも知れません。

******　ThisWorkbookの中に以下のコード　******
Private Sub Workbook_Deactivate()
Call Dataadd
End Sub

******　標準モジュールに以下のコード　******
Sub Dataadd()

Dim LastRow As Integer, Sheetname As String, Bookname As String, NRow As Integer
Dim O_LastRow As Integer, O_Sheetname As String, O_Bookname As String, O_Folder As String
Dim a As Variant, b As Variant

Application.ScreenUpdating = False
Bookname = ThisWorkbook.Name
O_Bookname = ActiveWorkbook.Name
O_Sheetname = ActiveSheet.Name

If Bookname <> O_Bookname Then
If Workbooks(O_Bookname).Worksheets(O_Sheetname).Range("B1").Value = "CSV確認用固定文字" Then

LastRow = Workbooks(Bookname).Sheets(1).Range("A65536").End(xlUp).Row
NRow = LastRow + 1
O_LastRow = Range("A65536").End(xlUp).Row '最下行を取得

Set a = Workbooks(O_Bookname).Worksheets(O_Sheetname).Range("A2:AA" & O_LastRow) 'UsedRange
Set b = Workbooks(Bookname).Sheets(1).Range("A" & NRow)

a.Copy (b)

Set a = Nothing
Set b = Nothing

Workbooks(O_Bookname).Activate
O_Folder = ActiveWorkbook.Path
ActiveWindow.Close

Cells.Font.Size = 10

'Kill (O_Folder & "\" & O_Bookname)　'コピー元ファイルを削除

End If
End If

Application.ScreenUpdating = True
End Sub