Excel VBA:データ結合マクロ
データ結合用(Excel形式、CSV形式両対応)型つくりました。Pythonでも同機能のもの作成してみます。
修正:12/15 データが一つしかない場合読まない問題解決

標準モジュール:FileDataMerge <結合用プロシジャー>
'結合データ配列
Dim MargeDataList As Variant
'結合データのサイズ設定用
Dim MaxDataRows As Long
Dim MaxDataCols As Long
Sub データ結合()
'====================================
'【目的】フォルダー内の複数データの結合マクロ
'【バージョン】Ver1.0
'【対象ファイル】CSV,Xlsx,xls,xlsm
'【対応】Excel2007以降Excel
'【方針】基本作成中は配列上の作業とし最終シート書き出し行う/データの取扱いとデータの成型及びファイル出力は分ける
'【変数名規則】機能_個別名⇒例:Cnt_Data:データ数カウント
'【動作フロー】
'①作業前事前準備:現データバックアップ→設定表「A5:A15」から有効な項目のみ抽出
'②取込作業:フォルダー選択(設定している場合、初期値に指定フォルダー名表記)各データ配列取込→メインの配列に結合結合表の成型→ファイル名をタグする→フィルター設置
'③全体の結果を残す
'====================================
'条件設定用配列
Dim InstanceRule1 As New FileRule
Dim SettingList As Variant
Dim Flag_FileOK As Boolean
Dim Flag_RuleOK As Boolean
Dim Ck_Data As Date
Dim Ck_PickupStart As String
'基本用各宣言
Dim i, j, k
Dim Ck_Start As String
'代入用
Dim Temp_Path, Temp_File, Temp_Sheet As String
Dim Temp_StartRow, Temp_StartCol, Ct_File, Ct_Data As Long
'シートの有無判定
Dim Ck_WorkSheet As Worksheet
Dim Flag_SheetOK As Boolean
Dim Temp_Sheetname As String
Ck_PickupStart = MsgBox("データ結合作成", vbOKCancel)
If (Ck_PickupStart = vbCancel) Then '作業中断
Exit Sub
End If
'===========①作業前事前準備============
'エラー時は強制終了
'On Error GoTo ErrorProcess
'アラームOFF
Application.DisplayAlerts = True
'自動計算OFF
Application.Calculation = xlCalculationManual
'シート固定
Application.ScreenUpdating = False
'作業前にバックアップ作成
Call Backup
'取込ルールの初期化
'設定取込
Sheets("設定画面").Select
MargeDataList = Range("A1:B1")
If (Range("A6") = "") Then 'データない場合中断
Exit Sub
Else
'ダミー格納→すぐに解除する配列を決定づけるために作成
SettingList = Range("A5:H15") '取込データリスト
Range("C1") = Format(Now, "yyyy/mm/dd hh:nn") '取込日
If (Range("F1") > 100) Then
MaxDataRows = Range("F1") '最大データ数あれば格納
Else
MaxDataRows = 1000000 '最大データ数100以下もしくはない場合1000000代入
Range("F1") = MaxDataRows '最大データ数表示
End If
End If
For i = 2 To UBound(SettingList) 'シートの有無判定→ない場合新規に対応シート作成する
If (SettingList(i, 1) <> "") Then
Flag_SheetOK = False
For Each Ck_WorkSheet In Worksheets
If Ck_WorkSheet.Name = SettingList(i, 1) Then Flag_SheetOK = True
Next Ck_WorkSheet
If Flag_SheetOK = False Then
'シートない場合追加→一番後ろに移動
Worksheets.Add.Name = SettingList(i, 1)
Worksheets(SettingList(i, 1)).Move After:=Worksheets(Worksheets.Count)
End If
End If
Next i
'===========②設定条件に合わせてフォルダー内の情報を取込作成============
'各シートにデータ格納→メインルーチンは条件式からのフィルタ格納
'条件に沿うもののみクラスインスタンス作成
For i = 2 To UBound(SettingList)
'結合用配列の初期化
Erase MargeDataList
MaxDataCols = 0
Set InstanceRule1 = New FileRule
'条件クラス代入
InstanceRule1.格納先シート = SettingList(i, 1)
InstanceRule1.ファイル名規則 = SettingList(i, 2)
If (InstanceRule1.格納先シート = "") Then
'シートがない場合問答無用でスキップ
ElseIf (InstanceRule1.ファイル名規則 Like "【無効】*" And InstanceRule1.格納先シート <> "") Then 'ファイル名ルールが無効ファイル名がない場合はスキップ
SettingList(i, 2) = InstanceRule1.ファイル名規則 'ファイル名無効の旨記録
Else '無効なファイル名がない場合のみデータ格納開始
InstanceRule1.フォルダーパス = SettingList(i, 8)
If (InstanceRule1.フォルダーパス <> "") Then '該当するフォルダーデータがあるときのみ作業する
Sheets(InstanceRule1.格納先シート).Select 'データ格納用シート選択<不要な上書き避けるため先に移動>
'設定条件読みだし
InstanceRule1.対象シート = SettingList(i, 3)
InstanceRule1.項目行番号 = SettingList(i, 4)
InstanceRule1.基準列番号 = SettingList(i, 5)
'格納先情報の初期化
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
'記録カウンター読み出し
InstanceRule1.対象シート = SettingList(i, 3)
'配列作成処理
Temp_Path = InstanceRule1.フォルダーパス
Temp_File = InstanceRule1.ファイル名規則
Temp_Sheet = InstanceRule1.対象シート
Temp_StartRow = InstanceRule1.項目行番号
Temp_StartCol = InstanceRule1.基準列番号
Ct_File = 0
Ct_Data = 0
If (Temp_File Like "*.csv") Then
Call 個別CSVデータ格納(Temp_Path, Temp_File, Temp_StartRow, Temp_StartCol, Ct_File, Ct_Data)
ElseIf ((Temp_File Like "*.xls?" Or Temp_File Like "*.xls") And Temp_Sheet <> "") Then
Call 個別Excelデータ格納(Temp_Path, Temp_File, Temp_Sheet, Temp_StartRow, Temp_StartCol, Ct_File, Ct_Data)
End If
Ct_Row = 1
InstanceRule1.データ数 = Ct_Data - 1
InstanceRule1.ファイル数 = Ct_File
InstanceRule1.フォルダーパス = Temp_Path
'データ作成後→シート貼り付け→状況記録
Sheets(InstanceRule1.格納先シート).Select
If (Ct_Data > 1) Then
Range(Cells(1, 1), Cells(Ct_Data, UBound(MargeDataList, 2))) = MargeDataList
End If
SettingList(i, 4) = InstanceRule1.項目行番号 '項目行位置設定
SettingList(i, 5) = InstanceRule1.基準列番号 '基準列位置設定
SettingList(i, 6) = InstanceRule1.データ数 'データ数
SettingList(i, 7) = InstanceRule1.ファイル数 'ファイル数格納
SettingList(i, 8) = InstanceRule1.フォルダーパス 'フォルダーパス格納
'対象ファイルにフィルタ設置
If (Range("B1") <> "") Then
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFilter
Range("A1").Select
End If
End If
End If
Set InstanceRule1 = Nothing '条件クラス開放
Next i
'===========③設定条件に合わせてフォルダー内の情報を取込作成============
Sheets("設定画面").Select
Range("A6:H15").ClearContents
Range("A5:H15") = SettingList
'シート固定解除
Application.ScreenUpdating = True
'自動計算ON
Application.Calculation = xlCalculationAutomatic
'アラームON
Application.DisplayAlerts = True
Exit Sub
ErrorProcess:
MsgBox ("エラー発生、終了します")
End Sub
Sub 個別CSVデータ格納(Temp_Path, Temp_File, Temp_StartRow, Temp_StartCol, Ct_File, Ct_Data)
'フォルダー内の指定ファイル読みだして配列順次結合
'一番初めのファイルは項目列から読み出し→項目列数+1=Main_DataColとして格納→固定データ<最後の列はファイル名格納用>
'Main_DataRowも一番ははじめは項目行~最終行までMain_DataRowとする
'⇒2つ目のファイルからは項目行の次の行を基準にする。またもし項目業の次のデータがない場合処理スキップする'
'元のデータ
Dim Orignal_Data As Variant
Dim Ck_Orignal_DataRow As Long
Dim Ck_Orignal_DataCol As Long
'フォルダー操作用の宣言
Dim FSO As Object
Dim Orignal_DataFile, buf_DataFile As String
Dim ct_TempFile As Long
Dim FileTypeTag As String
Dim Flag_DataExist As Boolean
'基本用各宣言
Dim i, j, k
'エラー時は強制スキップ
On Error GoTo ErrorProcess
'シート固定
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'==①事前準備:取込前の初期設定(初期値入力+値が不正の場合スキップする)
'==②ファイル読み込み→シート及び項目行の次の行データがある場合、データ取込 、安全装置として
buf_DataFile = Dir(Temp_Path & "\" & Temp_File) 'ファイルデータ読み出し用中継データ
Do While buf_DataFile <> "" Or ct_TempFile > 100000
ct_TempFile = ct_TempFile + 1 '無限ループ対策の安全弁
'ファイル開いて配列格納
Orignal_DataFile = Temp_Path & "\" & buf_DataFile
If Orignal_DataFile <> "False" Then
Workbooks.Open Orignal_DataFile 'ファイル開く
'開いたファイルの中身判定→エクセルシートあるときのみ処理(CSVはそのまま処理)
'データ判定用に最終行列抽出
Ck_Orignal_DataRow = Cells(Rows.Count, Temp_StartCol).End(xlUp).Row 'オリジナルデータ行数
Ck_Orignal_DataCol = Cells(Temp_StartRow, Columns.Count).End(xlToLeft).Column 'オリジナルデータ列数
'データ格納
If (Ck_Orignal_DataCol > Temp_StartCol And Ck_Orignal_DataRow > Temp_StartRow) Then
Orignal_Data = Range(Cells(Temp_StartRow, Temp_StartCol), Cells(Ck_Orignal_DataRow, Ck_Orignal_DataCol))
Else
Orignal_Data = Range(Cells(1, 1), Cells(1, 1))
End If
ActiveWorkbook.Close 'ファイル閉じる
If (UBound(Orignal_Data, 1) >= 2 And UBound(Orignal_Data, 2) > 0 And Ct_File = 0) Then '初期のファイルから核の配列作成
MaxDataCols = UBound(Orignal_Data, 2) + 1
ReDim MargeDataList(1 To MaxDataRows, 1 To MaxDataCols) '格納用結合配列の作成
For i = 1 To MaxDataCols - 1
MargeDataList(1, i) = Orignal_Data(1, i)
Next i
MargeDataList(1, MaxDataCols) = "取込元ファイル名"
Ct_Data = Ct_Data + 1
For i = 2 To UBound(Orignal_Data, 1)
Ct_Data = Ct_Data + 1
For j = 1 To MaxDataCols - 1
MargeDataList(Ct_Data, j) = Orignal_Data(i, j)
Next j
MargeDataList(Ct_Data, MaxDataCols) = buf_DataFile
Next i
Ct_File = Ct_File + 1
ElseIf (UBound(Orignal_Data, 1) >= 2 And UBound(Orignal_Data, 2) > 0 And Ct_File > 0) Then
For i = 2 To UBound(Orignal_Data, 1)
Ct_Data = Ct_Data + 1
For j = 1 To MaxDataCols - 1
MargeDataList(Ct_Data, j) = Orignal_Data(i, j)
Next j
MargeDataList(Ct_Data, MaxDataCols) = buf_DataFile
Next i
Ct_File = Ct_File + 1
End If
End If
Erase Orignal_Data 'オリジナルデータ格納初期化
buf_DataFile = Dir()
Loop
'シート固定
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
ErrorProcess:
End Sub
Sub 個別Excelデータ格納(Temp_Path, Temp_File, Temp_Sheet, Temp_StartRow, Temp_StartCol, Ct_File, Ct_Data)
'フォルダー内の指定ファイル読みだして配列順次結合
'一番初めのファイルは項目列から読み出し→項目列数+1=Main_DataColとして格納→固定データ<最後の列はファイル名格納用>
'Main_DataRowも一番ははじめは項目行~最終行までMain_DataRowとする
'⇒2つ目のファイルからは項目行の次の行を基準にする。またもし項目業の次のデータがない場合処理スキップする'
'元のデータ
Dim Orignal_Data As Variant
Dim Ck_Orignal_DataRow As Long
Dim Ck_Orignal_DataCol As Long
'フォルダー操作用の宣言
Dim FSO As Object
Dim Orignal_DataFile, buf_DataFile As String
Dim ct_TempFile As Long
Dim FileTypeTag As String
Dim Flag_DataExist As Boolean
'基本用各宣言
Dim i, j, k
'エラー時は強制スキップ
On Error GoTo ErrorProcess
'シート固定
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'==①事前準備:取込前の初期設定(初期値入力+値が不正の場合スキップする)
'==②ファイル読み込み→シート及び項目行の次の行データがある場合、データ取込 、安全装置として
buf_DataFile = Dir(Temp_Path & "\" & Temp_File) 'ファイルデータ読み出し用中継データ
Do While buf_DataFile <> "" Or ct_TempFile > 100000
ct_TempFile = ct_TempFile + 1 '無限ループ対策の安全弁
'ファイル開いて配列格納
Orignal_DataFile = Temp_Path & "\" & buf_DataFile
If Orignal_DataFile <> "False" Then
Workbooks.Open Orignal_DataFile 'ファイル開く
'開いたファイルの中身判定→エクセルシートあるときのみ処理(CSVはそのまま処理)
'開いたファイルの中身判定→エクセルシートあるときのみ処理
Dim ws As Worksheet, flag As Boolean
For Each ws In Worksheets
If ws.Name = Temp_Sheet Then flag = True
Next ws
If flag = True Then
Flag_DataExist = True
Sheets(Temp_Sheet).Select
'データ判定用に最終行列抽出
Ck_Orignal_DataRow = Cells(Rows.Count, Temp_StartCol).End(xlUp).Row 'オリジナルデータ行数
Ck_Orignal_DataCol = Cells(Temp_StartRow, Columns.Count).End(xlToLeft).Column 'オリジナルデータ列数
'データ格納
If (Ck_Orignal_DataCol > Temp_StartCol And Ck_Orignal_DataRow > Temp_StartRow) Then
Orignal_Data = Range(Cells(Temp_StartRow, Temp_StartCol), Cells(Ck_Orignal_DataRow, Ck_Orignal_DataCol))
Else
Orignal_Data = Range(Cells(1, 1), Cells(1, 1))
End If
Else
Orignal_Data = Range(Cells(1, 1), Cells(1, 1))
End If
ActiveWorkbook.Close 'ファイル閉じる
If (UBound(Orignal_Data, 1) >= 2 And UBound(Orignal_Data, 2) > 0 And Ct_File = 0) Then '初期のファイルから核の配列作成
MaxDataCols = UBound(Orignal_Data, 2) + 1
ReDim MargeDataList(1 To MaxDataRows, 1 To MaxDataCols) '格納用結合配列の作成
For i = 1 To MaxDataCols - 1
MargeDataList(1, i) = Orignal_Data(1, i)
Next i
MargeDataList(1, MaxDataCols) = "取込元ファイル名"
Ct_Data = Ct_Data + 1
For i = 2 To UBound(Orignal_Data, 1)
Ct_Data = Ct_Data + 1
For j = 1 To MaxDataCols - 1
MargeDataList(Ct_Data, j) = Orignal_Data(i, j)
Next j
MargeDataList(Ct_Data, MaxDataCols) = buf_DataFile
Next i
Ct_File = Ct_File + 1
ElseIf (UBound(Orignal_Data, 1) >= 2 And UBound(Orignal_Data, 2) > 0 And Ct_File > 0) Then
For i = 2 To UBound(Orignal_Data, 1)
Ct_Data = Ct_Data + 1
For j = 1 To MaxDataCols - 1
MargeDataList(Ct_Data, j) = Orignal_Data(i, j)
Next j
MargeDataList(Ct_Data, MaxDataCols) = buf_DataFile
Next i
Ct_File = Ct_File + 1
End If
End If
Erase Orignal_Data 'オリジナルデータ格納初期化
buf_DataFile = Dir()
Loop
'シート固定
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
ErrorProcess:
End Sub
Sub Backup()
'エラー時は強制終了
On Error GoTo ErrorProcess
Dim Ck_Backup As Integer
Dim Backup_FileName, Backup_FolderPath, Backup_FilePath As String
Dim Ck_BackupFolder
Ck_Backup = MsgBox("バックアップを作成して保存します。よろしいですか?", vbYesNo)
If Ck_Backup = vbNo Then Exit Sub
Backup_FileName = "結合データBackup" & Format(Now, "_yyyymmddhhnn") & ".xlsm"
Backup_FolderPath = ActiveWorkbook.Path & "\結合データBackup"
Ck_BackupFolder = Dir(Backup_FolderPath, vbDirectory)
If Ck_BackupFolder = "" Then 'フォルダが存在しない場合作成する
MkDir Backup_FolderPath
End If
'Backup後の保存先
Backup_FilePath = Backup_FolderPath & "\" & Backup_FileName
ActiveWorkbook.SaveCopyAs Backup_FilePath 'Backup保存実行
Exit Sub
ErrorProcess:
MsgBox ("エラー発生、終了します")
End Sub
標準モジュール:DataOutPut <出力用プロシジャー>
Sub データ出力()
With CSV_OutPut.DataListBox1
For i = 6 To 15
If (Cells(i, 1) <> "") Then
.AddItem Cells(i, 1)
End If
Next i
End With
CSV_OutPut.txtDate1 = Format(Range("C1"), "yyyymmdd-hhnn")
CSV_OutPut.Show
End Sub
クラスモジュール:FileRule<ファイル取込ルール格納用クラス>
'===============================
'ファイル結合用のファイルデータ確認用 クラスモジュール
'ファイル名判定機能とエラー時の判定機能はこのクラスにて確認
'===============================
'TR番号に対する条件のクラス,見分けつけるため「_」を最終文字に添付
Private 格納先シート_ As String '格納先シート
Private ファイル名規則_ As String 'ファイル名規則→xls?もしくはcsv拡張子無い場合ファイル名規則.無効にして無効とする
Private 対象シート_ As String '対象シート(エクセルのみ)→CSVファイルを設定した場合"/対象シート不要/"←わざとシート名に使えない文字記入→これにより間違って読まない
Private 項目行番号_ As Long '項目行番号 データの名前がある行 →記入がない場合1にする
Private 基準列番号_ As Long '基準列番号 データの開始される列 →記入がない場合1にする
Private フォルダーパス_ As String '建物種別切替
Private データ数_ As Long 'データ数→初期値 0
Private ファイル数_ As Long 'ファイル数→初期値 0
Private 項目数_ As Long '書き込み先にデータがある場合そのまま格納 ない場合⇒該当データ読み出し作成
'「格納先シート」というプロパティの設定プロシージャ
Property Let 格納先シート(ByVal new_格納先シート As String)
格納先シート_ = new_格納先シート
End Property
'「格納先シート」というプロパティの取得プロシージャ
Property Get 格納先シート() As String
格納先シート = 格納先シート_
End Property
'「ファイル名規則」というプロパティの設定プロシージャ、ファイル名規則がエクセルもしくはCSV形式でない場合無効
Property Let ファイル名規則(ByVal new_ファイル名規則 As String)
If (new_ファイル名規則 Like "*.xls?" Or new_ファイル名規則 Like "*.xls" Or new_ファイル名規則 Like "*.csv") Then
ファイル名規則_ = new_ファイル名規則
ElseIf (new_ファイル名規則 Like "【無効】*") Then
ファイル名規則_ = new_ファイル名規則
Else
ファイル名規則_ = "【無効】" & new_ファイル名規則
End If
End Property
'「ファイル名規則」というプロパティの取得プロシージャ
Property Get ファイル名規則() As String
ファイル名規則 = ファイル名規則_
End Property
'「対象シート」というプロパティの設定プロシージャ、対象シートがエクセルもしくはCSV形式でない場合無効
Property Let 対象シート(ByVal new_対象シート As String)
対象シート_ = new_対象シート
End Property
'「対象シート」というプロパティの取得プロシージャ
Property Get 対象シート() As String
対象シート = 対象シート_
End Property
'「項目行番号」というプロパティの設定プロシージャ 行番号がないもしくは文字などの場合 1を代入
Property Let 項目行番号(ByVal new_項目行番号 As Long)
If (new_項目行番号 > 0) Then
項目行番号_ = new_項目行番号
Else
項目行番号_ = 1
End If
End Property
'「項目行番号」というプロパティの取得プロシージャ
Property Get 項目行番号() As Long
項目行番号 = 項目行番号_
End Property
'「基準列番号」というプロパティの設定プロシージャ 列番号がないもしくは文字などの場合 1を代入
Property Let 基準列番号(ByVal new_基準列番号 As Long)
If (new_基準列番号 > 0) Then
基準列番号_ = new_基準列番号
Else
基準列番号_ = 1
End If
End Property
'「基準列番号」というプロパティの取得プロシージャ
Property Get 基準列番号() As Long
基準列番号 = 基準列番号_
End Property
'「データ数」というプロパティの設定プロシージャ
Property Let データ数(ByVal new_データ数 As Long)
データ数_ = new_データ数
End Property
'「データ数」というプロパティの取得プロシージャ
Property Get データ数() As Long
データ数 = データ数_
End Property
'「ファイル数」というプロパティの設定プロシージャ
Property Let ファイル数(ByVal new_ファイル数 As Long)
ファイル数_ = new_ファイル数
End Property
'「ファイル数」というプロパティの取得プロシージャ
Property Get ファイル数() As Long
ファイル数 = ファイル数_
End Property
'「フォルダーパス」というプロパティの設定プロシージャ
Property Let フォルダーパス(ByVal new_フォルダーパス As String)
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(new_フォルダーパス) Then
'指定フォルダーに変更なし
フォルダーパス_ = new_フォルダーパス
Else
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
new_フォルダーパス = .SelectedItems(1)
Else
new_フォルダーパス = ""
End If
End With
フォルダーパス_ = new_フォルダーパス
End If
Set FSO = Nothing
End Property
'「フォルダーパス」というプロパティの取得プロシージャ
Property Get フォルダーパス() As String
フォルダーパス = フォルダーパス_
End Property
'「項目数」というプロパティの設定プロシージャ
Property Let 項目数(ByVal new_項目数 As Long)
項目数_ = new_項目数
End Property
'「項目数」というプロパティの取得プロシージャ
Property Get 項目数() As Long
項目数 = 項目数_
End Property
フォーム:CSV_OutPut<CSV出力用フォーム>

Private Sub btClose1_Click()
Unload CSV_OutPut
End Sub
Private Sub btCSVOutput_Click()
'エラー時は強制スキップ
On Error GoTo ErrorProcess
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim FileName, Temp_Filename As String
Dim Re As Integer
Dim i, j As Long
With DataListBox1
For i = 0 To DataListBox1.ListCount - 1
If DataListBox1.Selected(i) = True Then
Temp_Filename = DataListBox1.List(i) & "_" & txtDate1.Text & ".csv"
Sheets(DataListBox1.List(i)).Copy
FileOutPut = Application.GetSaveAsFilename(InitialFileName:=Temp_Filename, FileFilter:="CSV ファイル (*.csv), *.csv")
ActiveWorkbook.SaveAs FileName:=FileOutPut, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
End If
Next i
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
ErrorProcess:
MsgBox "出力エラー"
End Sub

ディスカッション
コメント一覧
まだ、コメントがありません