複数のシートのデータを同じタイトルの列名でまとめるEXCELマクロ

以下のYahooブリーフケースからファイル
ConvineSheets.zip
をダウンロードし、中のEXCELファイルを開いてください。
簡単な使い方はファイルの中に書いてあります。
マクロの場所:
http://briefcase.yahoo.co.jp/bc/micnak2001/lst?&.dir=/3e2e&.src=bc&.view=l
http://sky.geocities.jp/robbie21st/
(2010-01-17 リンク変更)
#ニーズや要望があればエラー処理とかもうちょっとちゃんとしようかと思うのでコメントください。
#データが壊れたり、変なことしないように、ウィルスとかないように心がけていますが、使用の際には各自気をつけてくださいね。


ちなみに、列名とか関係なくシートをしてつないでいくマクロも

などで手に入ります。

    • 以下マクロの説明

http://q.hatena.ne.jp/1155902791

EXCELで複数のシートを1つのシートにまとめる方法がありましたら教えてください。
いちいちコピーして貼り付けるのが面倒です。

に関連してマクロを作ってみた。

今回の質問者の意図に沿うかはわからないが、こういうニーズはいろんな質問サイトでしばしば目にするので誰かの役に立つこともあろう。



「マクロの入ったファイルなんて怖い」という人は以下にコードの中心部分を載せますのでご自由に使用・改変・配布してください。

Dictionaryオブジェクトを使用しているため、VBEで "Microsoft Scripting Runtime"に参照設定しておく必要があります。

Dim ConvinedSheet As Worksheet
'開いているブックからシートを結合する
'
'1行目のタイトルが同じ列のデータは
'同じ列に結合する。


'sample 以下のマクロの使用方法サンプル
Sub sample()
    Init
    AddSheetData ThisWorkbook.Sheets("Sample1")
    AddSheetData ThisWorkbook.Sheets("Sample2")
End Sub


'初期化
Public Sub Init()
    Set ConvinedSheet = Workbooks.Add.Worksheets(1)
End Sub

'シートの追加
Sub AddSheetData(Sh As Worksheet)
    Dim DataStartRow As Range
    Set DataStartRow = LastUsedDataRow(ConvinedSheet).Offset(1, 0)
    
    Dim DataRange As Range
    Sh.Calculate
    Set DataRange = Range(Sh.Cells(1, 1), Sh.Cells.SpecialCells(xlCellTypeLastCell))
    Dim Col As Range
    For Each Col In DataRange.Columns
        Col.Copy
        Dim PasteTarget As Range
        Set PasteTarget = DataStartRow.Cells(1, ColumnNumber(Col.Cells(1).Value))
        PasteTarget.PasteSpecial xlPasteValuesAndNumberFormats
    Next
    DataStartRow.EntireRow.Delete Shift:=xlShiftUp
End Sub



'シートの中で、最後に使われたデータ保管のための行を返す
'1行目は列名が入るので除く
Private Function LastUsedDataRow(Sh As Worksheet) As Range
    Dim UsedRow As Range
    Set UsedRow = Sh.Cells.SpecialCells(xlCellTypeLastCell).EntireRow
    While WorksheetFunction.CountA(UsedRow) = 0 And UsedRow.Row > 1
        Set UsedRow = UsedRow.Offset(-1, 0)
    Wend
    Set LastUsedDataRow = UsedRow
End Function

'列名から、データを貼り付けるべき列番号を返す
Private Function ColumnNumber(FieldName As String) As Long
    Dim c As Range
    For Each c In ConvinedSheet.Rows(1).Cells
        If CStr(c.Value) = FieldName Then
            ColumnNumber = c.Column
            Exit For
        ElseIf CStr(c.Value) = "" Then
            c.Value = FieldName
            ColumnNumber = c.Column
            Exit For
        End If
    Next
End Function