フォルダ内のファイルをExcelでルーピングし、列を抽出し、1つの空の列を間に入れてマスターファイルに貼り付けます。

Question

最近、VBAの作業を開始し、プロジェクトを割り当ててプロジェクトを割り当てました。

今のところ、このマクロはすべてのExcelファイルのフォルダをループしています。それぞれの範囲を抽出し、その間に1つの空の列を置いて、マスターブックに1つずつ範囲を貼り付けます。

Master workbook

Source workbook1

私は別の元のブックを追加したいが、私の評判はまだこれを許可しません。

次のコードは私が過去数週間を思いついたものですが、それはもっとクリーンなものになると思います。

今のところ、貼り付けられた列の間に空の列を取得できません。何らかの理由で最後に抽出された列が2回貼り付けられます。

これらの問題を教えてください。

Sub SelectDataTestLoop2() 
    'Dim file location and file name etc. 
    Dim FilePath As Variant 
    Dim FileName As Variant 
    Dim WBcount As Integer 
    Dim OtherWB As Workbook 
    Dim ThisWB As Workbook 
    Dim ThisWS As Worksheet 
    Dim WS As Worksheet 

    'Sheet in which the data needs to be pasted (SignalCompilationFile) 
    Set ThisWB = ActiveWorkbook 
    Set ThisWS = ActiveSheet 

    'Define file location and file name 
    FilePath = "C:\Users\907443\Desktop\VBA Test\FileTestMap\" 
    FileName = Dir(FilePath & "*.xls?") 

    WScount = 0 

    'Loop over all files in a folder, copy/paste data 
    While FileName <> "" 
     Set OtherWB = Workbooks.Open(FilePath & FileName) 

     For Each WS In OtherWB.Worksheets 
      Set CopyRange = OtherWB.Worksheets(4).Range("H2:H114") 
      Set PasteRange = ThisWS.Cells(21, 14) 

      CopyRange.Copy 
      PasteRange.Offset(0, WScount).PasteSpecial xlPasteValues 

      WScount = WScount + (1/7) 
     Next WS 

     FileName = Dir() 
     Set OtherWB = Nothing 
    Wend 

    ThisWB.Activate 
    ThisWS.Activate 
    Set ThisWB = Nothing 
    Set ThisWS = Nothing 
End Sub 

Answer 1

あなたのコードにコメントしました。

Option Explicit 

Sub SelectDataTestLoop2() 
    'Dim file location and file name etc. 
    Dim FilePath As String     'Variant 
    Dim FileName As String     'Variant 
    Dim WBcount As Integer 
    Dim OtherWB As Workbook 
    Dim ThisWB As Workbook 
    Dim ThisWS As Worksheet 
    Dim WS As Worksheet 

    Dim CopyRange As Range     ' declare all variables 
    Dim TargetColumn As Long 

    'Sheet in which the data needs to be pasted (SignalCompilationFile) 
    Set ThisWB = ActiveWorkbook    ' logically, I expect ThisWorkbook 
    Set ThisWS = ActiveSheet 

    'Define file location and file name 
    FilePath = "C:\Users\907443\Desktop\VBA Test\FileTestMap\" 
    FileName = Dir(FilePath & "*.xls?") 

' WScount = 0        ' the Dim statement sets the value = 0 
              ' but there is no Dim statment for WScount 
              ' use "Option Explicit" at the top of your code sheet 

    TargetColumn = 2      ' define the frist column to paste to (2 = "B") 
    'Loop over all files in a folder, copy/paste data 
    While FileName <> "" 
     Set OtherWB = Workbooks.Open(FilePath & FileName) 

     For Each WS In OtherWB.Worksheets 
      Set CopyRange = OtherWB.Worksheets(4).Range("H2:H114") 
'   Set PasteRange = ThisWS.Cells(21, 14)  ' this specifies N21 

      CopyRange.Copy 
'   PasteRange.Offset(0, WScount).PasteSpecial xlPasteValues 
      ' paste to row 2 in Targetcolumn 
      ThisWS.Cells(2, TargetColumn).PasteSpecial 
      TargetColumn = TargetColumn + 2 

'   WScount = WScount + (1/7) 
      WBcount = WBcount + 1 
     Next WS 

     FileName = Dir() 
     OtherWB.Close SaveChanges:=False ' close the workbook after you are done with it 
'  Set OtherWB = Nothing 
    Wend 

' ThisWB.Activate      ' after all OtherWb are closed 
              ' this will be the ActiveWorkbook 
' ThisWS.Activate      ' - ditto - 
'' Set ThisWB = Nothing 
'' Set ThisWS = Nothing 
End Sub