デバッグ中のソースを添付します。
下記COLUMN_TITLEは、出力ファイルのタイトル(ヘッダー行)です。
COLUMN_PATTEN1とCOLUMN_PATTEN12は取得対象ファイルにより項目名が異なるため、2つ定義しました。
区分と新規/既存という項目は取得対象ファイルに存在してなく、マージ処理時に編集する対象項目です。
問題となっているのがこの取得対象ファイルに存在してない項目はどうすれば出力できるのか悩み中です。
区分:取得対象ファイル名より判定しセットする。
新規/既存:関数が入る(例:ifxxx,"aa","bb")
-----------------------------------------------------------------------------------------
Public Const COLUMN_TITLE = "更新日/作成日|氏名|年齢|性別|区分|項目1|新規/既存|項目2|項目3"
Public Const COLUMN_PATTEN1 = "作成日|氏名|年齢|性別|血液型|区分|項目1|新規/既存|項目2|項目3"
Public Const COLUMN_PATTEN2 = "更新日|氏名|年齢|性別|血液型|区分|項目1|新規/既存|項目2|項目3"
Public Const DIV_PATTEN = "関東地方|関西地方|海外地域"
Public Const DIV_PATTEN1 = "関東|関西|海外"
'シート名
Public Const MERGE_MIHAMA As String = "Merge_Result"
ここからは、処理ロジックです。
Private Sub CommandButton1_Click()
Dim mysavefile As String
Dim sSrsPath As String
ThisWorkbook.Activate
With Worksheets(MERGE_MIHAMA)
.Activate
.Cells.Select
Selection.ClearContents
Selection.Delete Shift:=xlUp
Cells.NumberFormat = "@"
' 見出し行
cols = Split(COLUMN_TITLE, "|")
For i = 0 To UBound(cols)
.Cells(1, i + 1).Value = cols(i)
Next
End With
sSrsPath = TextBox1.Value
Set myShell = CreateObject("WScript.shell")
Set myFso = CreateObject("Scripting.FileSystemObject")
Set myFolder = myFso.GetFolder(myShell.CurrentDirectory)
If myFso.FolderExists(sSrsPath) = False Then
MsgBox "フォルダが見つかりません"
Exit Sub
End If
Call myFso.GetFolder(sSrsPath)
For Each myfile In myFso.GetFolder(sSrsPath).Files
If InStr(1, myfile, ".xls") <> 0 Then
Call merge_a_file(myfile)
End If
Next myfile
mysavefile = sSrsPath & "\" & OUTPUT_ALL
Call saveAsNewBook(MERGE_MIHAMA, mysavefile)
End Sub
Private Sub merge_a_file(filename)
Dim div As String
Set this_book = ActiveWorkbook
'区分をファイル名から抽出
Set re = CreateObject("VBScript.RegExp")
re.Pattern = DIV_PATTEN
Set mat = re.Execute(filename)
If mat.Count = 0 Then
Exit Sub
End If
div = mat(0)
If div = "関西" Or div = "関東" Then
cols = Split(COLUMN_PATTEN2, "|")
Else
cols = Split(COLUMN_PATTEN1, "|")
Set col_map = CreateObject("Scripting.Dictionary")
re.Pattern = "^(" & COLUMN_PATTEN1 & ")$"
End If
Set ref_book = Workbooks.Open(filename)
' ひとつめのシート
Set ref_sheet = ref_book.Sheets(1)
'最大列数を取得
last_col = ref_sheet.Cells(1, Columns.Count).End(xlToLeft).Column
'対象項目と列番号の連想配列
For c = 1 To last_col
Set mat = re.Execute(ref_sheet.Cells(1, c).Value)
If mat.Count > 0 Then
col_map.Add mat(0).submatches(0), c
End If
Next
Set re = Nothing
this_book.Activate
this_book.Worksheets(MERGE_MIHAMA).Activate
Set this_sheet = ActiveSheet
' 参照シートの値を取り込む
last_row = ref_sheet.Cells(Rows.Count, 1).End(xlUp).Row
dest_row = Cells(Rows.Count, 1).End(xlUp).Row + 1
cols = Split(COLUMN_PATTEN1, "|")
With Worksheets(MERGE_MIHAMA)
For r = 2 To last_row
For i = 0 To UBound(cols)
Key = cols(i)
If col_map.exists(Key) Then
c = col_map.Item(Key)
.Cells(dest_row, i + 1).Value = ref_sheet.Cells(r, c).Value
End If
Next
dest_row = dest_row + 1
DoEvents
Next
Set col_map = Nothing
ref_book.Close
Set ref_book = Nothing
End With
End Sub
Private Sub saveAsNewBook(mySheetName As String, myFileName As String)
Dim myWS As Worksheet
ThisWorkbook.Activate
Set myWS = Worksheets(mySheetName)
If myWS Is Nothing Then
Exit Sub
End If
If myWS.Visible = False Then
myWS.Visible = True
End If
myWS.Cells.EntireColumn.AutoFit
myWS.Select
myWS.Copy
myWS.Visible = False
ActiveWorkbook.SaveAs myFileName, FileFormat:=xlNormal, CreateBackup:=False
End Sub