Note: The other languages of the website are Google-translated. Back to English

ディレクトリ内のファイルをループして、Excelのマスターシートにデータをコピーするにはどうすればよいですか?

XNUMXつのフォルダーに複数のExcelブックがあり、これらすべてのExcelファイルをループして、指定した範囲の同じ名前のワークシートからExcelのマスターワークシートにデータをコピーするとします。 この記事では、それを実現する方法を詳しく紹介します。

ディレクトリ内のファイルをループし、VBAコードを使用してデータをマスターシートにコピーします


ディレクトリ内のファイルをループし、VBAコードを使用してデータをマスターシートにコピーします

A1:D4の範囲で指定したデータを、特定のフォルダー内のブックのすべてのシート1からマスターシートにコピーする場合は、次のようにします。

1.ブックでマスターワークシートを作成し、を押します。 他の + F11 キーを押して アプリケーション向け Microsoft Visual Basic 窓。

2。 の中に アプリケーション向け Microsoft Visual Basic ウィンドウ、クリック インセット > モジュール。 次に、以下のVBAコードをコードウィンドウにコピーします。

VBAコード:フォルダー内のファイルをループし、データをマスターシートにコピーします

Sub Merge2MultiSheets()
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook, xWorkBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    xSheetName = "Sheet1"
    xRgStr = "A1:D4"
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            Set xWorkBook = ThisWorkbook
            Set xSheet = xWorkBook.Sheets("New Sheet")
            If xSheet Is Nothing Then
                xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count)).Name = "New Sheet"
                Set xSheet = xWorkBook.Sheets("New Sheet")
            End If
            xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
            If xFileName = "" Then Exit Sub
            Do Until xFileName = ""
               Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
                Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
                xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

注意:

1)。 コードでは、「A1:D4"と"Sheet1」は、すべてのSheet1の範囲A4:D1のデータがマスターシートにコピーされることを意味します。 そして「新しいシート」は、新しく作成されたマスターシートの名前です。
2)。 特定のフォルダ内のExcelファイルは開かないはずです。

3。 プレス F5 コードを実行するためのキー。

4.オープニングで ブラウズ ウィンドウで、ループするファイルが含まれているフォルダを選択して、[ OK ボタン。 スクリーンショットを参照してください:

次に、現在のワークブックの最後に「新しいシート」という名前のマスターワークシートが作成されます。 また、選択したフォルダ内のすべてのSheet1の範囲A4:D1のデータがワークシート内に一覧表示されます。


関連記事:


最高のオフィス生産性ツール

Kutools for Excelはほとんどの問題を解決し、生産性を80%向上させます

  • 再利用: すばやく挿入 複雑な数式、チャート および以前に使用したものすべて。 セルを暗号化する パスワード付き。 メーリングリストを作成する そしてメールを送る...
  • スーパーフォーミュラバー (複数行のテキストと数式を簡単に編集できます); 読書レイアウト (多数のセルを簡単に読み取って編集する); フィルター範囲に貼り付け...
  • セル/行/列をマージする データを失うことなく; 分割セルコンテンツ; 重複する行/列を組み合わせる...重複セルを防止します。 範囲を比較する...
  • [複製]または[一意]を選択します 行; 空白行を選択 (すべてのセルは空です); スーパーファインドとファジーファインド 多くのワークブックで; ランダム選択...
  • 正確なコピー 数式参照を変更せずに複数のセル。 参照の自動作成 複数のシートに; 箇条書きを挿入、チェックボックスなど...
  • テキストを抽出、テキストの追加、位置による削除、 スペースを削除する; ページング小計の作成と印刷。 セルの内容とコメントを変換する...
  • スーパーフィルター (フィルタースキームを保存して他のシートに適用します); 高度な並べ替え 月/週/日、頻度など。 特殊フィルター 太字、斜体...
  • ワークブックとワークシートを組み合わせる; キー列に基づいてテーブルをマージします。 データを複数のシートに分割; xls、xlsx、PDFをバッチ変換...
  • 300 以上の強力な機能. Office / Excel 2007-2021 および 365 をサポートします。すべての言語をサポートします。 企業や組織に簡単に導入できます。 フル機能の 30 日間無料トライアル。 60日間の返金保証。
kteタブ201905

Officeタブは、タブ付きのインターフェイスをOfficeにもたらし、作​​業をはるかに簡単にします

  • Word、Excel、PowerPointでタブ付きの編集と読み取りを有効にする、パブリッシャー、アクセス、Visioおよびプロジェクト。
  • 新しいウィンドウではなく、同じウィンドウの新しいタブで複数のドキュメントを開いて作成します。
  • 生産性を 50% 向上させ、毎日何百回もマウス クリックを減らすことができます!
officetab下部
コメントを並べ替える
コメント (20)
まだ評価はありません。 最初に評価してください!
このコメントは、サイトのモデレーターによって最小化されました
vbaコードをありがとう! それは完璧に動作します! 代わりに値として貼り付ける必要がある場合のコードを知りたいですか? 事前にThx!
このコメントは、サイトのモデレーターによって最小化されました
こんにちはライリン、
次のコードは、問題の解決に役立ちます。 コメントありがとうございます。

Sub Merge2MultiSheets()
範囲としての薄暗いxRg
バリアントとしての薄暗いxSelItem
Dim xFileDlg As FileDialog
Dim xFileName、xSheetName、xRgStr As String
Dim xBook、xWorkBook As Workbook
ワークシートとしての薄暗いxSheet
エラーで次の再開
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "Sheet1"
xRgStr = "A1:D4"
xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)を設定します
xFileDlgを使用
.Show = -1 の場合
xSelItem = .SelectedItems.Item(1)
xWorkBook=ThisWorkbookを設定します
xSheet = xWorkBook.Sheets( "New Sheet")を設定します
xSheetが何もない場合
xWorkBook.Sheets.Add(after:= xWorkBook.Worksheets(xWorkBook.Worksheets.count))。Name="新しいシート"
xSheet = xWorkBook.Sheets( "New Sheet")を設定します
終了する場合
xFileName = Dir(xSelItem& "\ *。xlsx"、vbNormal)
xFileName = ""の場合、Subを終了します
xFileName=""になるまで実行します
xBook = Workbooks.Open(xSelItem& "\"&xFileName)を設定します
xRg = xBook.Worksheets(xSheetName).Range(xRgStr)を設定します
xRg.Copy xSheet.Range( "A65536")。End(xlUp).Offset(1、0)
xFileName = Dir()
xBook.閉じる
ループ
終了する場合
最後に
xRg=xSheet.UsedRangeを設定します
xRg.ClearFormats
xRg.UseStandardHeight = True
xRg.UseStandardWidth = True
Application.DisplayAlerts = True
application.enablevents = true
Application.ScreenUpdating = True
End Subの
このコメントは、サイトのモデレーターによって最小化されました
こんにちは、コードをありがとう。 データ範囲のコピー元のExcelファイル名を含める方法を教えてください。 これは大きな助けになります!

ありがとうございました。
このコメントは、サイトのモデレーターによって最小化されました
こんにちは、

チュートリアルありがとうございます。

方法:「Sheet1」の行と「total」行の値のみをコピーし、「NewSheet」という名前のマスターワークシートに[filename]を付けて貼り付けます。 Totalの行に注意することは、ワークシートごとに異なる可能性があります。

例:
ファイル1:シート1
Col1、Col2、Colx
1,2,15
結果、10,50

ファイル2:シート1
Col1、Col2、Colx
1,5,10
2,4,16
3,3,6
4,5,6
5,7,10
結果、300,500

MasterFile: "新しいシート":
file1、10、50
file2、300、500
このコメントは、サイトのモデレーターによって最小化されました
こんにちは、これはうまくいきます。 数式ではなく値をプルオーバーするように変更する方法はありますか?
おかげで!
このコメントは、サイトのモデレーターによって最小化されました
こんにちはトリッシュ、
次のコードは、問題の解決に役立ちます。 コメントありがとうございます。

Sub Merge2MultiSheets()
範囲としての薄暗いxRg
バリアントとしての薄暗いxSelItem
Dim xFileDlg As FileDialog
Dim xFileName、xSheetName、xRgStr As String
Dim xBook、xWorkBook As Workbook
ワークシートとしての薄暗いxSheet
エラーで次の再開
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "Sheet1"
xRgStr = "A1:D4"
xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)を設定します
xFileDlgを使用
.Show = -1 の場合
xSelItem = .SelectedItems.Item(1)
xWorkBook=ThisWorkbookを設定します
xSheet = xWorkBook.Sheets( "New Sheet")を設定します
xSheetが何もない場合
xWorkBook.Sheets.Add(after:= xWorkBook.Worksheets(xWorkBook.Worksheets.count))。Name="新しいシート"
xSheet = xWorkBook.Sheets( "New Sheet")を設定します
終了する場合
xFileName = Dir(xSelItem& "\ *。xlsx"、vbNormal)
xFileName = ""の場合、Subを終了します
xFileName=""になるまで実行します
xBook = Workbooks.Open(xSelItem& "\"&xFileName)を設定します
xRg = xBook.Worksheets(xSheetName).Range(xRgStr)を設定します
xRg.Copy xSheet.Range( "A65536")。End(xlUp).Offset(1、0)
xFileName = Dir()
xBook.閉じる
ループ
終了する場合
最後に
xRg=xSheet.UsedRangeを設定します
xRg.ClearFormats
xRg.UseStandardHeight = True
xRg.UseStandardWidth = True
Application.DisplayAlerts = True
application.enablevents = true
Application.ScreenUpdating = True
End Subの
このコメントは、サイトのモデレーターによって最小化されました
こんにちは、それはまだ値ではなく数式を取得しているので、#REFエラーが発生します。 どこかに.PasteSpecialxlPasteValuesが必要な場合があることはわかっていますが、どこにあるのかわかりません。 手伝ってくれますか? ありがとう!
このコメントは、サイトのモデレーターによって最小化されました
こんにちはこれをありがとう。


すべてのフォルダーとサブフォルダーをループして上記のコピーを実行するコードを含めるにはどうすればよいですか?


ありがとうございます!
このコメントは、サイトのモデレーターによって最小化されました
こんにちは-このコードは、私が達成しようとしていることに最適です。

すべてのフォルダーとサブフォルダーをループしてコピーを実行する方法はありますか?


ありがとうございます!
このコメントは、サイトのモデレーターによって最小化されました
こんにちは-このコードは、すべてのファイルの最初の565行で非常にうまく機能しますが、その後のすべての行は次のファイルと重複しています。
これを修正する方法はありますか?
このコメントは、サイトのモデレーターによって最小化されました
ありがとうございます。ワークブック内の各ワークシートからメインのマスターファイル内の別々のシートに(特別な値を)コピーして貼り付けるにはどうすればよいでしょうか。
このコメントは、サイトのモデレーターによって最小化されました
セルが空の場合、どのようにコードを空白のままにするのですか?
このコメントは、サイトのモデレーターによって最小化されました
私の場合、「Sheet1」タブの名前はファイルごとに変わります。 たとえば、Tab1、Tab2、Tab3、Tab4 ... Excelでリストを実行し、すべてを実行するまで「Sheet1」の名前を変更し続けるループを設定するにはどうすればよいですか?
このコメントは、サイトのモデレーターによって最小化されました
こんにちはニック、以下のVBAコードは、問題の解決に役立ちます。 ぜひお試しください。 Sub LoopThroughFileRename()
'Extendofice2021/12/31によって更新
範囲としての薄暗いxRg
バリアントとしての薄暗いxSelItem
Dim xFileDlg As FileDialog
Dim xFileName、xSheetName、xRgStr As String
Dim xBook、xWorkBook As Workbook
ワークシートとしての薄暗いxSheet
シートとしての薄暗いxShs
Dim xName As String
Dim xFNum を整数として
エラーで次の再開
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)を設定します
xFileDlg.Show
xSelItem = xFileDlg.SelectedItems.Item(1)
xFileName = Dir(xSelItem& "\ *。xlsx"、vbNormal)
xFileName <> ""
xWorkBook = Workbooks.Open(xSelItem& "\"&xFileName)を設定します
xShs=xWorkBook.Sheetsを設定します
xFNum=1からxShs.Countの場合
xSheet = xShs.Item(xFNum)を設定します
xName = xSheet.Name
xName = Replace(xName、 "シート""タブ")'シートをタブに置き換えます
xSheet.Name = xName
次へ
xWorkBook.Save
xWorkBook.閉じる
xFileName = Dir()
ループ
Application.DisplayAlerts = True
application.enablevents = true
Application.ScreenUpdating = True
End Subの
このコメントは、サイトのモデレーターによって最小化されました
こんにちは、シートが含まれている6つの異なるワークブック(フォルダー内)のデータを新しいワークブックにコピーするコードが必要です。 vbaで
plz私を助けてください
このコメントは、サイトのモデレーターによって最小化されました
パラヌシャさん、こんにちは。
次の記事の VBA スクリプトは、複数のブックまたは指定されたブックのシートをマスター ブックに結合できます。 それが役立つかどうかを確認してください。
Excel で複数のブックを XNUMX つのマスター ブックに結合する方法
このコメントは、サイトのモデレーターによって最小化されました
Olá bom dia.
Gostei muito dessde código, mas não me ajudou com os relatórios que eu preciso impreimir.
Preciso imprimir 2.400 relatório de exel que estão em pastas diferentes e não estão configuradas corretamente para impressão. VBA で自動化された essas impressões を試してみませんか ? Me ajudaria muito, obrigada.
このコメントは、サイトのモデレーターによって最小化されました
こんにちは、マリア・ソアレスです。
次の投稿の VBA コードが役立つかどうかを確認してください。
Excelで複数のワークブックを印刷するにはどうすればよいですか?
このコメントは、サイトのモデレーターによって最小化されました
私のシナリオは似ていますが、各ファイルに複数のシートがあり、すべて名前が異なりますが、ファイル間で一貫しています。 このコードをループしてファイル内のデータをコピーし、(値) をマスター ワークブックの特定のシート名に貼り付ける方法はありますか? マスターのシート名はファイルと同じです。 それらをループしたい。 また、各シートのデータ量はさまざまであるため、次のような方法で各シートのデータを選択する必要があります。

Range( "A1")。Select
Range(Selection、Selection.End(xlDown))。Select
Range(Selection, Selection.End(xlToRight)).Select


ファイル シート名は、Giving、Services、Insurance、Car、Other Expenses などです。

よろしくお願いします。
このコメントは、サイトのモデレーターによって最小化されました
こんにちは、アンドリュー・シャハン
次の VBA コードで問題を解決できます。 コードを実行してフォルダーを選択すると、コードは自動的に名前でワークシートを照合し、データをマスター ブック内の同じ名前のワークシートに貼り付けます。
Sub Merge2MultiSheets()
'Updated by Extendoffice 20221209
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook As Workbook, xMainBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set xMainBook = ThisWorkbook
    
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
            If xFileName = "" Then Exit Sub
            
            Do Until xFileName = ""
            Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)

            For Start = 1 To xBook.Worksheets.Count
                Set xSheet = xBook.Worksheets.Item(Start)
                xSheet.Activate
                xSheetName = xSheet.Name
                xSheet.UsedRange.Copy (xMainBook.Worksheets.Item(xSheetName).Range("A1048576").End(xlUp).Offset(1, 0))
            Next
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
ここにはまだコメントが投稿されていません
あなたのコメントを残す
ゲストとして投稿
×
この投稿を評価:
0   文字
推奨される場所

フォローする

著作権©の2009 - WWW。extendoffice.com。 | | 全著作権所有。 搭載 ExtendOffice。 | サイトマップ
MicrosoftおよびOfficeのロゴは、米国MicrosoftCorporationの米国およびその他の国における商標または登録商標です。
SectigoSSLで保護