この記事では、ブック内のすべてのシートから新しいシートにデータをコピーするマクロを作成します。

この例の生データは、さまざまなシートのさまざまな部門の従業員の詳細で構成されています。従業員の詳細を1枚のシートに統合したいと考えています。

ArrowRawData

データを統合するための「CopyRangeFromMultipleSheets」マクロを作成しました。このマクロは、「データの統合」ボタンをクリックして実行できます。

ArrowMain

マクロは新しいワークシートを作成し、すべてのワークシートから統合データを挿入します。

ArrowOutput

コードの説明

すべてのシートを「ループ」して、「マスター」シートが存在するかどうかを確認します。

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]までご連絡ください