web-dev-qa-db-ja.com

VBAの列に基づいてExcelワークシートを複数のワークシートに分割する

質問は単純で、繰り返される場合があります。

  1. 約50列のExcelワークブックがあります
  2. このワークブックを複数のワークブックに分割するための基準列があります

アプローチは以下のとおりです。

Name    SportGoods    quantity
ABC     CRICKETBAT    10
DEF     BaseballBat   20
GHI     football      30 
MNO     gloves        10
PQR     shoes         10 
ABCD    CRICKET SHOES 10
DEFG    BaseballBat   20
GHIL    football      30 
MNOP    gloves        10
PQRS    shoes         10

列に基づいて複数のExcelワークブックを作成できるマクロを探していますSportGoods次のようになります。

  • CRICKETBAT、CRICKET SHOES、グローブなどのすべてのクリケットアイテムのExcel/CSV
  • サッカーや靴などのすべてのサッカーアイテムのExcel/CSV

入力パラメータとして、個別のクリケットアイテム、個別のサッカーアイテムを提供します。ソースは、最大5000レコードを含む大きなExcelデータシートになります。

上記の詳細に基づいて複数のワークブックを生成するのに役立つマクロを誰かが手伝ってくれますか？

microsoft-excelmicrosoft-excel-2010vba
2
Lohit

概要

これは短いですが、スマートなマクロです。アクティブシートのデータを分割して別のCSVファイルに保存します。新しく作成されたファイルは、Excelファイルと同じ場所にあるCSV出力という新しいフォルダーに保存されます。

VBAマクロ

_Sub GenerateCSV()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

iCol = 2                                '### Define your criteria column
strOutputFolder = "CSV output"          '### Define your path of output folder

Set ws = ThisWorkbook.ActiveSheet       '### Don't edit below this line
Set rngLast = Columns(iCol).Find("*", Cells(1, iCol), , , xlByColumns, xlPrevious)
ws.Columns(iCol).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUnique = Range(Cells(2, iCol), rngLast).SpecialCells(xlCellTypeVisible)

If Dir(strOutputFolder, vbDirectory) = vbNullString Then MkDir strOutputFolder
For Each strItem In rngUnique
  If strItem <> "" Then
    ws.UsedRange.AutoFilter Field:=iCol, Criteria1:=strItem.Value
    Workbooks.Add
    ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=[A1]
    strFilename = strOutputFolder & "\" & strItem
    ActiveWorkbook.SaveAs Filename:=strFilename, FileFormat:=xlCSV
    ActiveWorkbook.Close savechanges:=False
  End If
Next
ws.ShowAllData

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
_

新しいVBAモジュールに保存します

コードを理解する

_iCol = 2                               
strOutputFolder = "CSV output"        
_

最初の行は基準列です。 _1_は列Aを表し、_2_は列Bを表します。
次に、すべてのCSVファイルを保存するフォルダー名を定義します。 _C:\some\folder_のような完全修飾パスを設定することもできます。それ以外の場合、ExcelはExcelファイルの場所にフォルダを作成します


_ Set ws = ThisWorkbook.ActiveSheet      
_

ここでは、現在のワークブックとワークシートを変数に保存します。これを行う必要はありませんが、複数のワークブック（新しく作成されたもの）を扱っているので、これをお勧めします


_Set rngLast = Columns(iCol).Find("*", Cells(1, iCol), , , xlByColumns, xlPrevious)
ws.Columns(iCol).AdvancedFilter Action:=xlFilterInPlace, Unique:=True   
Set rngUnique = Range(Cells(2, iCol), rngLast).SpecialCells(xlCellTypeVisible)
_

わかりました、この部分は何ですか？まず、基準列でのみ最後のセルを検索します。これはフィルタリングの前に行う必要があり、後で必要になります。次に、有名な高度なフィルターメソッドを使用して、基準列からすべての重複値を適切にフィルターで除外します。最後に、すべてのvisibleセルをrngUniqueという変数に保存します。


_If Dir(strOutputFolder, vbDirectory) = vbNullString Then MkDir strOutputFolder
_

_CSV output_というフォルダがすでに存在するかどうかを確認しましょう。そうでない場合は、作成します


_For Each strItem In rngUnique
  If strItem <> "" Then
  [...]
  End If
Next
_

ここで、変数rngUnique内のすべての一意の値のループを開始します。ただし、空の値はスキップされます


_ws.UsedRange.AutoFilter Field:=iCol, Criteria1:=strItem.Value
_

重要な行。オートフィルターメソッドを使用して、現在の一意の値に一致するすべての行を表示します。古い高度なフィルターは自動的にキャンセルされます。


_Workbooks.Add
ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=[A1]
_

これらの2行は、新しい空のワークブックを作成し、入力ワークブックから表示されているセルのみをコピーします


_strFilename = strOutputFolder & "\" & strItem
_

ここでは、CSVパスをまとめます。現在の一意の値をファイル名として使用します。出力形式としてxlCSVを選択したため、拡張子[〜＃〜] csv [〜＃〜]が自動的に追加されます。
一意の値に_< > | / * \ ? "_などの無効なファイル名文字が含まれていないことを確認してください。含まれていないと、対応するCSVファイルが作成されません


_ActiveWorkbook.SaveAs Filename:=strFilename, FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False
_

最後のステップは、現在のブックをCSVとして保存し、変数strFilenameをファイル名として取得することです。 CSV区切り文字は、地域の設定区切り文字に依存します。 ファイル形式を変更する 、例えば。タブ区切りのCSVまたはExcel2003ワークブックに


_Application.ScreenUpdating = False
Application.DisplayAlerts = False
_

Excelはフィルタリングのすべてのステップを表示する必要がないため、最初の行はマクロを少し高速化します。
2行目は、迷惑なファイルが既に存在するプロンプトを抑制します。後でそれらの機能を再び有効にします

4
nixda