Microsoft ExcelでVBAを使用して一枚に各シートの範囲をコピーし
この記事では、ブック内のすべてのシートから新しいシートにデータをコピーするマクロを作成します。
この例の生データは、さまざまなシートのさまざまな部門の従業員の詳細で構成されています。従業員の詳細を1枚のシートに統合したいと考えています。
データを統合するための「CopyRangeFromMultipleSheets」マクロを作成しました。このマクロは、「データの統合」ボタンをクリックして実行できます。
マクロは新しいワークシートを作成し、すべてのワークシートから統合データを挿入します。
コードの説明
すべてのシートを「ループ」して、「マスター」シートが存在するかどうかを確認します。
ThisWorkbook.Worksheetsの各ソースについてSource.Name = “Master” Then MsgBox “マスターシートは既に存在します”
サブエンドを終了次の場合上記のコードを使用して、「マスター」シートがワークブックに存在するかどうかを確認します。 「マスター」シートがワークブックに存在する場合、コードは終了し、エラーメッセージが表示されます。
Source.Range( “A1″)。SpecialCells(xlLastCell).Row上記のコードは、シートの最後のセルの行番号を取得するために使用されます。
Source.Range( “A1″、Range( “A1″)。SpecialCells(xlLastCell))。Copy Destination.Range( “A”&DestLastRow)
上記のコードは、指定された範囲を定義されたセルにコピーするために使用されます。
コードについては以下に従ってください
Sub CopyRangeFromMultipleSheets() 'Declaring variables Dim Source As Worksheet Dim Destination As Worksheet Dim SourceLastRow, DestLastRow As Long Application.ScreenUpdating = False 'Looping through all sheets to check whether "Master" sheet exist For Each Source In ThisWorkbook.Worksheets If Source.Name = "Master" Then MsgBox "Master sheet already exist" Exit Sub End If Next 'Inserting a new sheet after the "Main" sheet Set Destination = Worksheets.Add(after:=Sheets("Main")) Destination.Name = "Master" 'Looping through all the sheets in the workbook For Each Source In ThisWorkbook.Worksheets 'Preventing consolidation of data from "Main" and "Master" sheet If Source.Name <> "Main" And Source.Name <> "Master" Then SourceLastRow = Source.Range("A1").SpecialCells(xlLastCell).Row Source.Activate If Source.UsedRange.Count > 1 Then DestLastRow = Sheets("Master").Range("A1").SpecialCells(xlLastCell).Row If DestLastRow = 1 Then 'copying data from the source sheet to destination sheet Source.Range("A1", Range("A1").SpecialCells(xlLastCell)).Copy Destination.Range("A" & DestLastRow) Else Source.Range("A2", Range("A1").SpecialCells(xlCellTypeLastCell)).Copy Destination.Range("A" & (DestLastRow + 1)) End If End If End If Next Destination.Activate Application.ScreenUpdating = True End Sub
このブログが気に入ったら、FacebookやFacebookで友達と共有してください。
皆様からのご意見をお待ちしております。私たちの仕事を改善し、あなたのために改善する方法をお知らせください。 [email protected]までご連絡ください