VBAを使用してカラム上で複数のファイルをベースに分割Excelのシート
Excelシートにビッグデータがあり、列のデータに基づいて、そのシートを複数のシートに分散する必要がありますか？これは非常に基本的なタスクですが、時間がかかります。
たとえば、私はこのデータを持っています。このデータには、Date、Writer、Titleという名前の列があります。作家欄には、それぞれのタイトルの作家名が記載されています。各作家のデータを別々のシートにまとめたいと思います。
これを手動で行うには、次のことを行う必要があります：
。 1つの名前をフィルタリングします。フィルタリングされたデータをコピーします。シートを追加します。データを貼り付けます。シートの名前を変更します。それぞれについて、上記の5つの手順をすべて繰り返します。
この例では、名前は3つしかありません。何百もの名前があると想像してみてください。
データをどのように異なるシートに分割しますか？それは多くの時間がかかり、それはあなたも消耗します。
シートを複数のシートに分割する上記のプロセスを自動化するには、次の手順に従います。
Alt + F11を押します。これにより、Excel用のVBエディターが開きます。新しいモジュールを追加します。*モジュール内のコードの下にコピーします。
Sub SplitIntoSheets()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
ThisWorkbook.Activate
Sheet1.Activate
'clearing filter if any
On Error Resume Next
Sheet1.ShowAllData
On Error GoTo 0
Dim lsrClm As Long
Dim lstRow As Long
'counting last used row
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim uniques As Range
Dim clm As String, clmNo As Long
On Error GoTo handler
clm = Application.InputBox("From which column you want create files" & vbCrLf & "E.g. A,B,C,AB,ZA etc.")
clmNo = Range(clm & "1").Column
Set uniques = Range(clm & "2:" & clm & lstRow)
'Calling Remove Duplicates to Get Unique Names
Set uniques = RemoveDuplicates(uniques)
Call CreateSheets(uniques, clmNo)
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AlertBeforeOverwriting = True
.Calculation = xlCalculationAutomatic
End With
Sheet1.Activate
MsgBox "Well Done!"
Exit Sub
Data.ShowAllData
handler:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AlertBeforeOverwriting = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Function RemoveDuplicates(uniques As Range) As Range
ThisWorkbook.Activate
Sheets.Add
On Error Resume Next
ActiveSheet.Name = "uniques"
Sheets("uniques").Activate
On Error GoTo 0
uniques.Copy
Cells(2, 1).Activate
ActiveCell.PasteSpecial xlPasteValues
Range("A1").Value = "uniques"
Dim lstRow As Long
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:A" & lstRow).Select
ActiveSheet.Range(Selection.Address).RemoveDuplicates Columns:=1, Header:=xlNo
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Set RemoveDuplicates = Range("A2:A" & lstRow)
End Function
Sub CreateSheets(uniques As Range, clmNo As Long)
Dim lstClm As Long
Dim lstRow As Long
For Each unique In uniques
Sheet1.Activate
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
lstClm = Cells(1, Columns.Count).End(xlToLeft).Column
Dim dataSet As Range
Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))
dataSet.AutoFilter field:=clmNo, Criteria1:=unique.Value
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
lstClm = Cells(1, Columns.Count).End(xlToLeft).Column
Debug.Print lstRow; lstClm
Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))
dataSet.Copy
Sheets.Add
ActiveSheet.Name = unique.Value2
ActiveCell.PasteSpecial xlPasteAll
Next unique
End Sub
SplitIntoSheets（）プロシージャを実行すると、シートは特定の列に基づいて複数のシートに分割されます。シートにボタンを追加して、このマクロを割り当てることができます。
仕組み
上記のコードには、2つのプロシージャと1つの関数があります。 2つのプロシージャはSplitIntoSheets（）、CreateSheets（uniques As Range、clmNo As Long）であり、1つの関数はRemoveDuplicates（uniques As Range）AsRangeです。最初のプロシージャはSplitIntoSheets（）です。これが主な手順です。このプロシージャは、変数とRemoveDuplicatesを設定して、指定された列から一意の名前を取得し、それらの名前をCreateSheetsに渡してシートを作成します。
RemoveDuplicatesは、名前を含む範囲である1つの引数を取ります。
それらから重複を削除し、一意の名前を含む範囲オブジェクトを返します。
これで、CreateSheetsが呼び出されます。 2つの引数が必要です。最初に一意の名前、次に列番号。そこからデータを適合させます。これで、CreateSheetsは一意から各名前を取得し、指定された列番号を各名前でフィルタリングします。フィルタリングされたデータをコピーし、シートを追加して、そこにデータを貼り付けます。そして、あなたのデータは数秒で異なるシートに分割されます。
ここからファイルをダウンロードできます。
シートに分割
ファイルの使用方法：
-
Sheet1にデータをコピーします。 A1から始まることを確認してください。
[シートに分割]ボタンをクリックします*分割する列の文字を入力します。 [OK]をクリックします。
-
次のようなプロンプトが表示されます。シートが分割されます。
データを別々のシートに分割することに関する記事がお役に立てば幸いです。これまたはExcelの他の機能について疑問がある場合は、以下のコメントセクションでお気軽にお問い合わせください。