フォルダ内に3つのExcelファイルのマージについて、

①それぞれのファイルは1行目タイトル行、2行目以降はデータが入ってます。
②それぞれのタイトルの項目数が異なります。
やりたいことは、それぞれのExcelファイルから、予め決められたタイトル(※1)の項目値を取得し、縦に並べて(※2)1つの新しいExcelとして保存する処理をしたいです。
※1 各ファイルの共通項目をPickupし、5項目ほどのタイトル行をつけます。タイトル行の例は以下です。
区分 氏名 年齢 性別 血液型 備考
また、
1項目目は各ファイル名から判断し、区分という項目名を付けます。
例:ファイル名に”関東”が含まれた場合、区分に”関東”をつける
ファイル名に”関西”が含まれた場合、区分に”関西”をつける
ファイル名に”東北”が含まれた場合、区分に”東北”をつける
※2 1行名はタイトル行2行目は各ファイルを走行しタイトルの項目名に当該するデータ行を取得してコピーします。
補足:備考の項目は”関東”が含まれるファイルにのみ存在する。”関西””東北”の場合、データ行をグレー色にて示します。
Excel/VBAは不慣れでご教授いただけると嬉しいです。よろしくお願いします。

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2016/04/22 00:02:59
  • 終了:2016/04/29 00:05:03

回答(1件)

id:a-kuma3 No.1

a-kuma3回答回数4325ベストアンサー獲得回数17732016/04/22 15:26:55

以下のコードを標準モジュールに貼り付けて、定数 BASE_DIR に三つのシートがあるディレクトリ名をフルパスで設定してください。
そして、merge_files サブルーチンを実行してください。
開いているシートに三つのファイルからデータを取り込みます。

Const COLUMN_PATTERN = "氏名|年齢|性別|血液型|備考"
Const DIV_PATTERN = "関東|関西|東北"
Const BASE_DIR = "D:\foo\bar"

Sub merge_a_file(filename)
    Set this_book = ActiveWorkbook
    Set this_sheet = ActiveSheet

    Set ref_book = Workbooks.Open(BASE_DIR & "\" & filename)
    Set ref_sheet = ref_book.Sheets(1)  ' ひとつめのシート

    ' 区分をファイル名から抽出
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = DIV_PATTERN
    Set mat = re.Execute(filename)
    If mat.Count = 0 Then
        Exit Sub
    End If
    div = mat(0)

    ' 取り込む列位置を求める
    Set col_map = CreateObject("Scripting.Dictionary")
    re.Pattern = "^(" & COLUMN_PATTERN & ")$"
    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_sheet.Activate

    ' 参照シートの値を取り込む
    last_row = ref_sheet.Cells(Rows.Count, 1).End(xlUp).Row
    dest_row = Cells(Rows.Count, 1).End(xlUp).Row + 1
    cols = Split(COLUMN_PATTERN, "|")
    For r = 2 To last_row
        Cells(dest_row, 1).Value = div
        For i = 0 To UBound(cols)
            Key = cols(i)
            If col_map.exists(Key) Then
                c = col_map.Item(Key)
                Cells(dest_row, i + 2).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 Sub

Sub merge_files()
    ' 取り込み対象のファイル名
    Dim filelist(3)
    filelist(1) = "data関東.xlsx"
    filelist(2) = "関西リスト.xlsx"
    filelist(3) = "20160422 東北一覧.xlsx"

    ' 見出し行
    Cells(1, 1).Value = "区分"
    cols = Split(COLUMN_PATTERN, "|")
    For i = 0 To UBound(cols)
        Cells(1, i + 2).Value = cols(i)
    Next

    ' クリア
    Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, UBound(cols))).Clear

    ' ファイルから取り込む
    For i = 1 To UBound(filelist)
        Call merge_a_file(filelist(i))
    Next

    ' ファイルを保存する
    new_name = "data_" & Format(Now, "yyyymmddHHMMSS") & ".xlsm"
    ActiveWorkbook.SaveAs new_name, xlOpenXMLWorkbookMacroEnabled

End Sub

質問では条件に挙げられていなくて、前提にしていること。

  • 取り込む三つの Excel の一番目のシートから取り込みます
  • 取り込むシートで、A列に値が入っている最後の行まで取り込みます
  • 途中に空白行があっても、そのまま取り込みます
  • 取り込むのは値だけです。書式などは取り込みません
  • 取り込みシートに数式が書いてあっても、値として取り込みます
  • データを取り込む前に、シートをクリアしています

補足:備考の項目は”関東”が含まれるファイルにのみ存在する。”関西””東北”の場合、データ行をグレー色にて示します。

備考に限らず、取り込み先のタイトル行に定数 COLUMN_PATTERN で指定した項目がなければ、取り込み開始前にシートをクリアしているので、空白のままになります。
「データ行をグレー色にて示します」のところはよく分からないので、特に扱ってません。


追記です。

ファイルを保存する処理を、上記のコードに追記しました。
「data_年月日時分秒.xlsm」というファイル名で保存します。


追記です。

なお、2 3 4 5 6 のようなデータが混入される

見出し行の項目の名前の一部が重複する場合に対応できるように、上記のコードを修正しました。

  • id:myonlinebookmark
    a-kuma3様
    ご回答頂きありがとうございます。
    すぐには確認が出来なくて申し訳ございません。
    頂いたサンプルを実行してみましたが、結果シートが生成されず、対象ファイル読み込むだけのようです。
    ファイルから取り込むのあと、シート保存処理を追加するイメージですか。
    すみませんが、よろしくお願いします。
  • id:a-kuma3
    回答に追記して、マクロのコードを修正しました。
  • id:myonlinebookmark
    a-kuma3様
    確認が遅くなり申し訳ありません。
    こちらでもデバッグしておりますが、
    下記のようマージ対象項目が約60個ある場合、正しく出力されないことが発覚しました。
    ※事象:6列目までしか生成されない。なお、2 3 4 5 6 のようなデータが混入される

    Const COLUMN_PATTERN = "区分|氏名|年齢|性別|血液型||備考|項目1|項目2|項目3|項目4|項目5|項目6|項目7|項目8|項目9|項目10|項目11|項目12|項目13|項目14|項目15|項目16|項目17|項目18|項目19|項目20|項目21|項目22|項目23|項目24|項目25|項目26|項目27|項目28|項目29|項目30項目31|項目32|項目33|項目34|項目35|項目36|項目37|項目38|項目39|項目40|項目41|項目42|項目43|項目44|項目45|項目46|項目47|項目48|項目49|項目50"
  • id:a-kuma3
    >>
    6列目までしか生成されない
    <<
    COLUMN_PATTERN の「血液型」と「備考」の間が、縦棒がふたつ入ってます。
    ひとつだけにしてください。

    >>
    なお、2 3 4 5 6 のようなデータが混入される
    <<
    回答のコードを修正しました。
    見出し行の項目の一部が重複している場合でも、正しく抽出できるようにしたつもりです。

    実際に使われている場面と、質問で書かれている見出し行の内容が違うのだと思いますが、実際に使う場面に限りなく近い形で質問をした方が、こういった手戻りが少なくて済みます。
  • id:myonlinebookmark
    a-kuma3様
    ご親切にご回答頂きありがとうございます。
    頂いたプログラムをデバッグしながら、確認させて頂きました。
    >>
    実際に使う場面に限りなく近い形で質問をした方が、こういった手戻りが少なくて済みます。
    <<
    承知しました。実際に処理する内容を下記のとおり補足させて頂きます。


    ①マージ結果は別シート※にて設定し、完了後新しいファイルとして保存する
     ※例:Merge_Resultというシートを作成して、非表示にしておきます。なお、Merge_Resultシートの1行目はヘッダー行を固定にてつける。
    ②全体の流れは、シート(例:Sheet1)にボタンを作成し、押下されたら、対象フォルダから対象ファイルを読み込み、
    ①のように別シート(Merge_Resultという非表示シート)で生成された結果を新しいファイルとして保存する

    ■一応自力で上記のような処理内容を書いてみたが、期待とおりの結果が得られなかった。
    ファイル生成のところに問題があると思いますが、初心者のため、原因はすぐにはわかりません。。。
    ヒント頂けたら嬉しいです。

    Const COLUMN_PATTERN = "区分|氏名|年齢|性別|血液型||備考|項目1|項目2|項目3|項目4|項目5|項目6|項目7"
    Const DIV_PATTERN = "関東|関西|東北"

    Const MERGE_MIHAMA As String = "Merge_Result" '別シートでマージ結果をコピー

    Const BASE_DIR As String = "D:\foo\bar"

    Private Sub CommandButton1_Click()

    ' 取り込み対象のファイル名
    Dim filelist(3)
    filelist(1) = "data関東.xlsx"
    filelist(2) = "関西リスト.xlsx"
    filelist(3) = "20160422 東北一覧.xlsx"

    ' 見出し行
    'Cells(1, 1).Value = "地域名"
    'cols = Split(COLUMN_PATTERN, "|")
    'For i = 0 To UBound(cols)
    ' Cells(1, i + 2).Value = cols(i)
    'Next

    ' クリア
    'Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 60)).Clear
    Range(Cells(2, 1), Cells(Cells(Rows.Count, 2).End(xlUp).Row + 1, 60 + 1)).Clear

    ' ファイルから取り込む
    For i = 1 To UBound(filelist)
    Call merge_a_file(filelist(i))
    Next


    '指定シートを新規ブックとして保存
    Call saveAsNewBook(MERGE_MIHAMA, BASE_DIR)

    ' ファイルを保存する
    MsgBox "完了しました。", vbInformation + vbOKOnly
    Workbooks(MERGE_MIHAMA).Active


    'new_name = "data_" & Format(Now, "yyyymmddHHMMSS") & ".xlsm"
    'ActiveWorkbook.SaveAs new_name, xlOpenXMLWorkbookMacroEnabled

    End Sub
    Private Sub merge_a_file(filename)

    Set this_book = ActiveWorkbook
    Set this_sheet = ActiveSheet

    With Worksheets(MERGE_MIHAMA)


    Set ref_book = Workbooks.Open(BASE_DIR & "\" & filename)
    ' ひとつめのシート
    Set ref_sheet = ref_book.Sheets(1)


    ' 区分をファイル名から抽出
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = DIV_PATTERN

    Set mat = re.Execute(filename)
    If mat.Count = 0 Then
    Exit Sub
    End If
    div = mat(0)

    ' 取り込む列位置を求める
    Set col_map = CreateObject("Scripting.Dictionary")
    re.Pattern = "^(" & COLUMN_PATTERN & ")$"


    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_sheet.Activate

    ' 参照シートの値を取り込む
    last_row = ref_sheet.Cells(Rows.Count, 1).End(xlUp).Row
    dest_row = Cells(Rows.Count, 1).End(xlUp).Row + 1
    cols = Split(COLUMN_PATTERN, "|")
    For r = 2 To last_row
    Cells(dest_row, 1).Value = div
    For i = 0 To UBound(cols)
    Key = cols(i)
    If col_map.exists(Key) Then
    c = col_map.Item(Key)
    Cells(dest_row, i + 2).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

    'シートが非表示だとSELECTエラーになる
    If myWS.Visible = False Then
    myWS.Visible = True
    End If

    myWS.Cells.EntireColumn.AutoFit
    myWS.Select
    myWS.Copy

    '名前つけて保存
    ActiveWorkbook.SaveAs filename:=myFileName, FileFormat:=xlNormal, ReadOnlyRecommended:=False, CreateBackup:=False

    End Sub


    追記:
    頂いたプログラムのデータ行のクリアで、
    Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 60)).Clear
    を実行したところ、1行目が消されてしまいますので、以下のように変更させて頂きました。
    Range(Cells(2, 1), Cells(Cells(Rows.Count, 2).End(xlUp).Row + 1, 60 + 1)).Clear'2行目(データ行)以降クリア
  • id:a-kuma3
    >期待とおりの結果が得られなかった。
    どんなことを期待してて、こうなっているのが期待してることと違う、ということを書いてもらわないと、よく分かりません。
    ざっと見た感じ、ファイルができてないのだとは思いますが。

    サブルーチン saveAsNewBook は、ふたつの引数を取るように作ってるようですが、2番目の引数は myFileName としているように、ファイル名を期待して書いています。

    一方、呼び出す方は、

      '指定シートを新規ブックとして保存
      Call saveAsNewBook(MERGE_MIHAMA, BASE_DIR)

    とあります。2番目に指定しているのはディレクトリです。
    既に存在しているディレクトリを、ブックのファイル名として保存しているので、正しく保存できないのだと思います。

    存在していないファイル名を指定すれば良いように思います。
    保存のフォーマットをを xlNormal にしてますから、拡張子を .xls にして、こんな感じにするとか。

      '指定シートを新規ブックとして保存
      new_name = "data_" & Format(Now, "yyyymmddHHMMSS") & ".xls"
      Call saveAsNewBook(MERGE_MIHAMA, BASE_DIR & "\" & new_name)
  • id:myonlinebookmark
    a-kuma3様
    早速ご回答いただきありがとうございます。
    言葉足らずで申し訳ありません。
    期待している結果は、Merge_Resultシートのマージ結果を別ファイルにて保存することですが、
    ご指摘頂いたファイル名の指定を直してみて、実行したところ、
    Merge_Resultシートは別ファイルで保存されてました。
    しかし、
    データ行はありませんでした。
    下記のようなヘッダー行しかありませんでした。

    地域名 区分 氏名 年齢 性別 血液型 備考 項目1 項目2 項目3 項目4 項目5 項目6 項目7

    参照シートの値を取り込むの処理で、

    Private Sub merge_a_file(filename)

    With Worksheets(MERGE_MIHAMA)
    ・・・

    Cells(dest_row, i + 2).Value = ref_sheet.Cells(r, c).Value

    End With

    シート名(MERGE_MIHAMA=”Merge_Result”)指定しても、
    Cells(dest_row, i + 2).Value = ref_sheet.Cells(r, c).Valueで認識されていないようです。
    もう少し追ってみます。

  • id:a-kuma3
    ああ、アクティブなシートにデータが取り込まれてるんですよね。
    With の使い方が間違ってます。

    With Worksheets(MERGE_MIHAMA)
      ...

      .Cells(dest_row, i + 2).Value = ref_sheet.Cells(r, c).Value

    End With

    というように、Cells の前にピリオドが必要です。
  • id:myonlinebookmark
    a-kuma3様
    お世話様です。
    ご回答いただきありがとうございます。ご指摘されたとおり、Cells の前にピリオドをつけて再度実行したら、うまくいきました。ありがとうございました。ピリオドは大事ですね!
    ※とても勉強になりました。ありがとうございました。
    一応修正後のソースコードを以下のとおり添付致します。

    Const COLUMN_PATTERN = "区分|氏名|年齢|性別|血液型||備考|項目1|項目2|項目3|項目4|項目5|項目6|項目7"
    Const DIV_PATTERN = "関東|関西|東北"

    Const MERGE_MIHAMA As String = "Merge_Result"

    Const BASE_DIR As String = "D:\foo\bar"
    Const BASE_FileName = "D:\foo\bar\mergall\mrgall.xls"
    Private Sub CommandButton1_Click()

    ' 取り込み対象のファイル名
    Dim filelist(3)
    filelist(1) = "data関東.xlsx"
    filelist(2) = "関西リスト.xlsx"
    filelist(3) = "20160422 東北一覧.xlsx"

    Application.ScreenUpdating = False
    ThisWorkbook.Activate
    With Worksheets(MERGE_MIHAMA)
    .Activate
    .Cells.Select
    Selection.ClearContents
    Selection.Delete Shift:=xlUp
    Cells.NumberFormat = "@"
    ' 見出し行
    .Cells(1, 1).Value = "地域名"
    cols = Split(COLUMN_PATTERN, "|")
    For i = 0 To UBound(cols)
    .Cells(1, i + 2).Value = cols(i)
    Next
    End With

    ' ファイルから取り込む
    For i = 1 To UBound(filelist)
    Call merge_a_file(filelist(i))
    Next

    '指定シートを新規ブックとして保存
    Call saveAsNewBook(MERGE_MIHAMA, BASE_FileName)

    ' ファイルを保存する
    MsgBox "完了しました。", vbInformation + vbOKOnly

    End Sub
    Private Sub merge_a_file(filename)

    Set this_book = ActiveWorkbook
    cols = Split(COLUMN_PATTERN, "|")
    Set ref_book = Workbooks.Open(BASE_DIR & "\" & filename)
    ' ひとつめのシート
    Set ref_sheet = ref_book.Sheets(1)
    ' 区分をファイル名から抽出
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = DIV_PATTERN
    Set mat = re.Execute(filename)
    If mat.Count = 0 Then
    Exit Sub
    End If
    div = mat(0)

    ' 取り込む列位置を求める
    Set col_map = CreateObject("Scripting.Dictionary")
    re.Pattern = "^(" & COLUMN_PATTERN & ")$"

    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_PATTERN, "|")

    With Worksheets(MERGE_MIHAMA)

    For r = 2 To last_row
    this_sheet.Cells(dest_row, 1).Value = div
    For i = 0 To UBound(cols)
    Key = cols(i)
    If col_map.exists(Key) Then
    c = col_map.Item(Key)
    .Cells(dest_row, i + 2).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

    'シートが非表示だとSELECTエラーになる
    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


    ■いまいち、ActiveSheetの使い方はわかってないが、どのタイミングでシート名をしなくてもいいのか。。。
    ■なぜか、ファイル出力で、怒られました
    ActiveWorkbook.SaveAs myFileName, FileFormat:=xlNormal, CreateBackup:=False
    原因はわかりません。。。
  • id:a-kuma3
    >■いまいち、ActiveSheetの使い方はわかってないが、どのタイミングでシート名をしなくてもいいのか。。。
    手動で Excel を操作しているときに、目の前に見えているシートが ActiveSheet です。
    複数のシートを扱うなら、常に名前か順序を指定して Worksheet オブジェクトを使う方が紛れがないかもしれません。


    >■なぜか、ファイル出力で、怒られました
    SaveAs メソッドは、同名のファイルがあると「置き換えますか」って聞いてきたと思います。

    ・常に新規なファイルになるようにファイル名を決める(ぼくの回答)
    ・ファイルが存在するかどうかを調べて、SaveAs と Save メソッドを使い分ける
    ・同名のファイルがあったら、削除してから保存する

    というようなどれかの対応をすることになります。
  • id:myonlinebookmark
    a-kuma3さま
    お世話様です。
    ご回答いただきありがとうございます。
    了解しました。自分で色々と調べて、調査してみます。
    質問させて頂いた内容について、解決できましたので、お礼申し上げます。

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

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

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

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