長文ですみません。取得対象Excelファイルからのマージ処理で出力項目を編集したい

Excel/VBAで3つのExcelファイルから予め定義された項目をもとにマージ処理を行い、その結果を出力しようと思います。連想配列を使っていますが、期待とおりの結果は得られませんでしたので、助けを求めたいと思います。

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2016/05/12 00:41:54
  • 終了:2016/05/19 00:45:04
id:myonlinebookmark

デバッグ中のソースを添付します。
下記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

回答(0件)

回答はまだありません

  • id:nanacy7741
    (もちろん意地悪言いたいわけじゃないんだけど)
    その聞き方じゃあ何回やっても相手にされないんじゃないですかね。
    エクセル系の質問をよく回答してくれてる人ですら全く反応ないんだから。
  • id:myonlinebookmark
    ナナシーさん
    コメント頂きありがとうございます。
    質問の内容をよく考えてから出しますので、いったんキャンセルさせて頂ければと思います。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません