Microsoft ExcelでVBAを使用して、フォルダ内の各ワークブックの範囲をコピーし
この記事では、フォルダー内の複数のブックから新しいブックにデータをコピーするマクロを作成します。
2つのマクロを作成します。 1つのマクロは最初の列から新しいブックにレコードをコピーするだけで、2番目のマクロはすべてのデータをその列にコピーします。
この例の生データは、従業員の出席記録で構成されています。
TestFolderには、複数のExcelファイルがあります。 Excelファイルのファイル名は、特定の日付を「ddmmyyyy」形式で表します。
各Excelファイルには、その特定の日に出席した従業員の日付、従業員ID、および従業員名が含まれています。
2つのマクロを作成しました。 「CopyingSingleColumnData」および「CopyingMultipleColumnData」。 「CopyingSingleColumnData」マクロは、フォルダー内のすべてのファイルの最初の列から新しいブックにのみレコードをコピーします。 「CopyingMultipleColumnData」マクロは、フォルダー内のすべてのファイルからすべてのデータを新しいブックにコピーします。
「CopyingSingleColumnData」マクロは、「CopyingSingleColumn」ボタンをクリックして実行できます。 「CopyingMultipleColumnData」マクロは、「CopyingMultipleColumns」ボタンをクリックして実行できます。
マクロを実行する前に、Excelファイルが配置されるテキストボックスにフォルダのパスを指定する必要があります。
「単一列のコピー」ボタンをクリックすると、新しいワークブック「ConsolidatedFile」が定義されたフォルダーに生成されます。このワークブックには、フォルダー内のすべてのファイルの最初の列からの統合データが含まれます。
新しいワークブックは最初の列にはレコードのみが含まれます。統合データを取得すると、日付の数を数えることで特定の日に存在する従業員の数を見つけることができます。特定の日付の数は、その特定の日に存在する従業員の数と等しくなります。
「複数の列をコピーする」ボタンをクリックすると、定義されたフォルダーに新しいワークブック「ConsolidatedAllColumns」が生成されます。このワークブックには、フォルダー内のすべてのファイルのすべてのレコードからの統合データが含まれます。
作成された新しいワークブックには、フォルダー内のすべてのファイルのすべてのレコードが含まれます。統合されたデータを取得すると、すべての出席の詳細を1つのファイルで利用できるようになります。その特定の日に出席した従業員の数を簡単に見つけることができ、その特定の日に出席した従業員の名前も取得できます。
コードの説明
Sheet1.TextBox1.Value上記のコードは、シート「Sheet1」からテキストボックス「TextBox1」に挿入された値を取得するために使用されます。
Dir（FolderPath＆ “* .xlsx”）
上記のコードは、ファイル拡張子が「.xlsx」のファイルの名前を取得するために使用されます。複数文字のファイル名にはワイルドカード*を使用しています。
FileName <> “”
Count1 = Count1 + 1 ReDim Preserve FileArray（1 To Count1）
FileArray（Count1）= FileName FileName = Dir（）
上記のコードは、フォルダ内のすべてのファイルのファイル名を取得するために使用されます。
i = 1の場合UBound（FileArray）へ
次の上記のコードは、フォルダー内のすべてのファイルをループするために使用されます。
Range（ “A1″、Cells（LastRow、1））。Copy DestWB.ActiveSheet.Cells（LastDesRow、1）
上記のコードは、最初の列からコピー先のブックにレコードをコピーするために使用されます。
Range（ “A1″、ActiveCell.SpecialCells（xlCellTypeLastCell））。Copy DestWB.ActiveSheet.Cells（LastDesRow、1）
上記のコードは、アクティブなブックから宛先のブックにすべてのレコードをコピーするために使用されます。
コードについては以下に従ってください
Option Explicit
Sub CopyingSingleColumnData()
'Declaring variables
Dim FileName, FolderPath, FileArray(), FileName1 As String
Dim LastRow, LastDesRow, Count1, i As Integer
Dim SourceWB, DestWB As Workbook
Application.ScreenUpdating = False
FolderPath = Sheet1.TextBox1.Value
'Inserting backslash in the folder path if backslash(\) is missing
If Right(FolderPath, 1) <> "\" Then
FolderPath = FolderPath & "\"
End If
'Searching for Excel files
FileName = Dir(FolderPath & "*.xlsx")
Count1 = 0
'Looping through all the Excel files in the folder
While FileName <> ""
Count1 = Count1 + 1
ReDim Preserve FileArray(1 To Count1)
FileArray(Count1) = FileName
FileName = Dir()
Wend
'Creating a new workbook
Set DestWB = Workbooks.Add
For i = 1 To UBound(FileArray)
'Finding the last row in the workbook
LastDesRow = DestWB.ActiveSheet.Range("A1").SpecialCells(xlCellTypeLastCell).Row
'Opening the Excel workbook
Set SourceWB = Workbooks.Open(FolderPath & FileArray(i))
LastRow = ActiveCell.SpecialCells(xlCellTypeLastCell).Row
'Pasting the copied data to last row in the destination workbook
If LastDesRow = 1 Then
'Copying the first column to last row in the destination workbook
Range("A1", Cells(LastRow, 1)).Copy DestWB.ActiveSheet.Cells(LastDesRow, 1)
Else
Range("A1", Cells(LastRow, 1)).Copy DestWB.ActiveSheet.Cells(LastDesRow + 1, 1)
End If
SourceWB.Close False
Next
'Saving and closing a new Excel workbook
DestWB.SaveAs FileName:=FolderPath & "ConsolidatedFile.xlsx"
DestWB.Close
Set DestWB = Nothing
Set SourceWB = Nothing
End Sub
Sub CopyingMultipleColumnData()
'Declaring variables
Dim FileName, FolderPath, FileArray(), FileName1 As String
Dim LastRow, LastDesRow, Count1, i As Integer
Dim SourceWB, DestWB As Workbook
Application.ScreenUpdating = False
FolderPath = Sheet1.TextBox1.Value
'Inserting backslash in the folder path if backslash(\) is missing
If Right(FolderPath, 1) <> "\" Then
FolderPath = FolderPath & "\"
End If
'Searching for Excel files
FileName = Dir(FolderPath & "*.xlsx")
Count1 = 0
'Looping through all the Excel files in the folder
While FileName <> ""
Count1 = Count1 + 1
ReDim Preserve FileArray(1 To Count1)
FileArray(Count1) = FileName
FileName = Dir()
Wend
'Creating a new workbook
Set DestWB = Workbooks.Add
For i = 1 To UBound(FileArray)
'Finding the last row in the workbook
LastDesRow = DestWB.ActiveSheet.Range("A1").SpecialCells(xlCellTypeLastCell).Row
'Opening the Excel workbook
Set SourceWB = Workbooks.Open(FolderPath & FileArray(i))
'Pasting the copied data to last row in the destination workbook
If LastDesRow = 1 Then
'Copying all data in the worksheet to last row in the destination workbook
Range("A1", ActiveCell.SpecialCells(xlCellTypeLastCell)).Copy DestWB.ActiveSheet.Cells(LastDesRow, 1)
Else
Range("A1", ActiveCell.SpecialCells(xlCellTypeLastCell)).Copy DestWB.ActiveSheet.Cells(LastDesRow + 1, 1)
End If
SourceWB.Close False
Next
'Saving and closing a new Excel workbook
DestWB.SaveAs FileName:=FolderPath & "ConsolidatedAllColumns.xlsx"
DestWB.Close
Set DestWB = Nothing
Set SourceWB = Nothing
End Sub
このブログが気に入ったら、FacebookやFacebookで友達と共有してください。
皆様からのご意見をお待ちしております。私たちの仕事を改善し、あなたのために改善する方法をお知らせください。 [email protected]までご連絡ください