Excel VBA：フォルダー内データ抽出マクロ
フォルダー内の定型フォーマットのエクセルファイルからデータを読み出しリスト化するマクロ作成しました。
- 複数シートに対応。
- 必要な情報はセルアドレスとシート名で指定
- シート名等に相違がある場合、読み込まない仕様にしています
- バックアップ機能は別途作成したコード使用
Sub エクセル資料からのデータ抽出()
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
'【目的】フォルダー内のエクセルデータ抽出
'【バージョン】Ver1.0
'【対象ファイル】xlsx,xls,xlsm
'【対応】Excel2007以降Excel
'【方針】シート上のデータ読出し→リスト化
'【変数名規則】機能_個別名⇒例：Cnt_Data:データ数カウント
'【動作フロー】
'①作業前事前準備：呼び出しデータ選択⇒選択したデータから読取用の配列作成
'②取込作業：フォルダー選択（設定している場合、初期値に指定フォルダー名表記）各データ配列取込→メインの配列に結合結合表の成型
'③貼り付け作業：ファイル名をタグ→フィルター設置
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
'結合データ配列
Dim MargeDataList As Variant
'結合データのサイズ設定用
Dim MaxDataRows As Long
Dim MaxDataCols As Long
'条件設定
Dim buf_Path, Temp_Path, Temp_File, Temp_Sheet, Temp_Address As String
Dim Ct_File, Ct_Data As Long
Dim SettingList(1 To 50, 1 To 4) 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, MaxRows As Long
Dim Ck_Start As String
'シートの有無判定
Dim Ck_WorkSheet As Worksheet
Dim Flag_SheetOK As Boolean
Dim Temp_Sheetname As String
'フォルダー操作用の宣言
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
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("A26") = "") Then 'データない場合中断
Exit Sub
Else
'ダミー格納→すぐに解除する配列を決定づけるために作成
Range("C1") = Format(Now, "yyyy/mm/dd hh:nn") '取込日
Temp_Sheetname = Range("A26") '格納先シート名
MaxRows = Cells(Rows.Count, 1).End(xlUp).Row
Flag_RuleOK = False
If (MaxRows > 30) Then
For i = 30 To MaxRows 'データ表示”1”があり、情報が完備されていることが継続条件
If (Range("A" & i) = Temp_Sheetname And Range("C" & i) = 1 And Range("D" & i) <> "" And Range("E" & i) <> "" And (Range("F" & i) Like "*.xls" Or Range("F" & i) Like "*.xls?")) Then
Temp_File = Range("F" & i) 'ファイル名規則
buf_Path = Range("G" & i) 'フォルダ情報がない場合読み込み
Temp_Path = PickUpPath(buf_Path)
If (Temp_Path <> "") Then
Range("G" & i) = Temp_Path
Flag_RuleOK = True
End If
End If
Next i
End If
End If
'取込準備、格納用配列準備
If (Flag_RuleOK = True) Then '条件がそろってる場合のみ→OK
'データ格納用配列→及び1の番号のある内容にデータそろえる(いざという時のバックアップに)
j = 1
For i = 30 To MaxRows '
If (Range("A" & i) = Temp_Sheetname) Then
Range("F" & i) = Temp_File '基準になる行のデータ書き込み
Range("G" & i) = Temp_Path '基準になる行のデータ書き込み
SettingList(j, 1) = Range("B" & i) '項目名
SettingList(j, 2) = Range("C" & i) '並び順
SettingList(j, 3) = Range("D" & i) 'シート名
SettingList(j, 4) = Range("E" & i) 'アドレス
j = j + 1
End If
Next i
'項目数にファイル情報を格納する列追加した分が格納先の項目数となる→jのカウント数
MaxDataCols = j
If (Range("F1") > 100) Then
MaxDataRows = Range("F1") '最大データ数あれば格納
Else
MaxDataRows = 100000 '最大データ数100以下もしくはない場合1000000代入
Range("F1") = MaxDataRows '最大データ数表示
End If
'格納用配列作成→1行目を項目行／2行目シート名／3行目をアドレス格納用に固定仕様→情報不足のところには“Null”
ReDim MargeDataList(1 To MaxDataRows, 1 To MaxDataCols)
MargeDataList(3, MaxDataCols) = "識別Tag"
MargeDataList(1, MaxDataCols) = "取込元"
MargeDataList(2, MaxDataCols) = "ファイル名"
For i = 1 To MaxDataCols - 1
MargeDataList(3, SettingList(i, 2)) = SettingList(i, 1)
MargeDataList(1, SettingList(i, 2)) = SettingList(i, 3)
MargeDataList(2, SettingList(i, 2)) = SettingList(i, 4)
Next i
'シートの有無判定及び、シート作成
Flag_SheetOK = False
For Each Ck_WorkSheet In Worksheets
If Ck_WorkSheet.Name = Temp_Sheetname Then Flag_SheetOK = True
Next Ck_WorkSheet
If Flag_SheetOK = False Then
'シートない場合追加→一番後ろに移動
Worksheets.Add.Name = Temp_Sheetname
Worksheets(Temp_Sheetname).Move After:=Worksheets(Worksheets.Count)
End If
'格納先情報の初期化
Sheets(Temp_Sheetname).Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Else
MsgBox "抽出情報が不足しています"
Exit Sub
End If
Ct_Data = MaxDataRows
'＝＝＝＝＝＝＝＝＝＝＝②設定条件に合わせてフォルダー内の情報を取込作成＝＝＝＝＝＝＝＝＝＝＝＝
buf_DataFile = Dir(Temp_Path & "\" & Temp_File) 'ファイルデータ読み出し用中継データ
Ct_Data = 3
Do While buf_DataFile <> "" Or ct_TempFile > 100000
ct_TempFile = ct_TempFile + 1 '無限ループ対策の安全弁
'ファイル開いて配列格納
Orignal_DataFile = Temp_Path & "\" & buf_DataFile
If Orignal_DataFile <> "False" Then
Ct_Data = Ct_Data + 1
Workbooks.Open Orignal_DataFile 'ファイル開く
For i = 1 To MaxDataCols - 1
On Error Resume Next
MargeDataList(Ct_Data, i) = Sheets(MargeDataList(1, i)).Range(MargeDataList(2, i)).Value
On Error GoTo 0
Next i
MargeDataList(Ct_Data, MaxDataCols) = buf_DataFile
ActiveWorkbook.Close 'ファイル閉じる
End If
buf_DataFile = Dir()
Loop
'＝＝＝＝＝＝＝＝＝＝＝③データ格納＝＝＝＝＝＝＝＝＝＝＝＝
Sheets(Temp_Sheetname).Select
Range(Cells(1, 1), Cells(Ct_Data, MaxDataCols)) = MargeDataList
'不要行の削除
Rows("1:2").Select
Selection.Delete Shift:=xlUp
'表の成型、フィルターセット
Columns("A:G").Select
Selection.ColumnWidth = 20
Rows("1:1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.RowHeight = 25
Selection.Font.Size = 9
'フィルタ設置
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFilter
Range("A1").Select
Sheets("設定画面").Select
Range("A26").Select
'シート固定解除
Application.ScreenUpdating = True
'自動計算ON
Application.Calculation = xlCalculationAutomatic
'アラームON
Application.DisplayAlerts = True
Exit Sub
ErrorProcess:
MsgBox ("エラー発生、終了します")
End Sub
Function PickUpPath(ByVal buf_Path As String) 'フォルダー判定用ファンクション
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(buf_Path) Then
'指定フォルダーに変更なし
PickUpPath = buf_Path
Else
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
PickUpPath = .SelectedItems(1)
Else
PickUpPath = ""
End If
End With
End If
Set FSO = Nothing
End Function
Sub 項目作成()
'
' 記録データから項目作成
'
Sheets("設定画面").Select
Dim MaxRows As Long
Dim i As Long
Dim DataList As String
MaxRows = Cells(Rows.Count, 1).End(xlUp).Row
Sheets("設定画面").Select
Range("A26").Select
Selection.Validation.Delete
If (MaxRows > 30) Then
DataList = ""
For i = 30 To MaxRows
If (Range("A" & i) <> "" And Not DataList Like "*" & Range("A" & i) & "*") Then
DataList = DataList & "," & Range("A" & i)
End If
Next i
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=DataList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With
End If
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