[[20130517140530]]　『初心者のため、お知恵を借りたくてここに来ました。どなたかご教示願えればありがたいです。　ページの最後に飛ぶ

『初心者のため、お知恵を借りたくてここに来ました。どなたかご教示願えればありがたいです。
１つのフォルダ内に転記用ファイル及び複数の同一書式データファイル（シート１～シ
ート８、各シート同一書式）が存在します。データファイル中のＡ列に付けられている識別番号１～１１を検索して識別番号１の付いているもの（Ｂ列～Ｅ列を）から識別番号２・・・１１と順番に転記用ファイルのＡ２列～Ｄ２列に転記させるには、どんなコードがありますか？

 　
　　　　　転記用ファイル　　　　　　　　　　　　データファイル
　　　Ａ　　Ｂ　　Ｃ　　Ｄ　　　　　　  Ａ　　　　Ｂ　　Ｃ　　Ｄ　　Ｅ
１　 項目　項目　項目　項目　　　１　　識別番号　項目　項目　項目　項目
２　　　　　　　　　　　　　　　 ２　　 １
３　　　　　　　　　　　　　　　 ３　　 ２
４　　　　　　　　　　　　　　　 ４　　 ３
　　　　　　　　　　　　　　　　　　　  ４
　　　　　　　　　　　　　　　　　　　　２
　　　　　　　　　　　　　　　　　　　　１１

』（さおり）

 各データファイルの各シートには、同じ識別番号が複数ある？　それとも１つだけ？

 (ぶらっと)

 サンプルを見ると識別番号に複数の同一番号があったり、ないものがありますが
 単純に識別番号の小さい順に列挙すればよいのですか？

 またデータファイル、シートは複数あるとありますが、転記用ファイルは１つなのでしょうか。
 その場合複数のデータをどのように1シートに纏めるか、ルールはないのですか？
 ファイル間、シート間の優先順位がなければ、全データのA:E列を転記用シートにコピーし、
 A列でソート後に、A列を削除した結果と同じようになればよいのでしょうか。
 (Mook)

 あぁ、そうか！
 今、力技のコードを書いてアップしようとしたら Mookさんのコメントが！！

 そうですねぇ、そうすればいいわけですね。

 (ぶらっと)

ぶらっと様、Mook様書込みありがとうございます。
仕事で外出していたものでご返事遅れてすいません。
各データファイルの各シートには同じ識別番号が複数あります。
また、識別番号は、１～１１まであり、単純に識別番号が小さい順に列挙できれば良いです。転記用ファイルは１つで、この転記用ファイルにマクロをおいて、データファイルからデータを取得して、識別番号の小さい順に列挙したいのです。また、掲載サンプルがずれてしまっていますので、修正しました。よろしくお願いいたします。
（さおり）

 Sample1 が最初に書いた力技。Sample2はMookさんのコメントによるコード案。

 Sub Sample1()
    Dim myPath As String
    Dim fName As String
    Dim tSh As Worksheet
    Dim wb As Workbook
    Dim fSh As Worksheet
    Dim v(1 To 11) As Object
    Dim x As Long
    Dim c As Range
    Dim dic As Variant

    Application.ScreenUpdating = False

    For x = 1 To UBound(v)
        Set v(x) = CreateObject("Scripting.Dictionary")
    Next

    myPath = "c:\TEST\" 'フォルダパスは実際のものに
    '転記シート名は実際のものに
    Set tSh = ThisWorkbook.Sheets("Sheet1")
    tSh.Range("A1", tSh.UsedRange).Offset(1).ClearContents

    fName = Dir(myPath & "*.xls")

    Do While Len(fName) > 0
        If fName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(myPath & fName)
            For Each fSh In wb.Worksheets
                For Each c In fSh.Range("A2", fSh.Range("A" & fSh.Rows.Count).End(xlUp))
                    Select Case c.Value
                        Case 1 To UBound(v)
                            v(c.Value)(v(c.Value).Count) = c.Offset(, 1).Resize(, 4).Value
                    End Select
                Next
            Next
            wb.Close False
        End If
        fName = Dir()
    Loop

    For Each dic In v
        If dic.Count > 0 Then
            tSh.Range("A" & tSh.Rows.Count).End(xlUp).Offset(1).Resize(dic.Count, 4).Value = _
                        WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))
        End If
    Next

    Application.Goto tSh.Range("A1")
    Application.ScreenUpdating = True

    MsgBox "統合完了"

 End Sub

 Sub Sample2()
    Dim myPath As String
    Dim fName As String
    Dim tSh As Worksheet
    Dim wb As Workbook
    Dim fSh As Worksheet
    Dim x As Long
    Dim c As Range
    Dim sv As Variant

    Application.ScreenUpdating = False

    myPath = "c:\TEST\" 'フォルダパスは実際のものに
    '転記シート名は実際のものに
    Set tSh = ThisWorkbook.Sheets("Sheet1")
    sv = tSh.Range("A1:E1").Value
    tSh.Cells.ClearContents

    fName = Dir(myPath & "*.xls")

    Do While Len(fName) > 0
        If fName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(myPath & fName)
            For Each fSh In wb.Worksheets
                With fSh.Range("A2", fSh.Range("A" & fSh.Rows.Count).End(xlUp)).Resize(, 5)
                    tSh.Range("A" & tSh.Rows.Count).End(xlUp).Offset(1).Resize(.Rows.Count, .Columns.Count).Value = .Value
                End With
            Next
            wb.Close False
        End If
        fName = Dir()
    Loop

    With tSh
        .Range("B1:F1").Value = sv
        .Range("A1").CurrentRegion.Sort Key1:=.Columns("A"), Order1:=xlAscending, Header:=xlYes
        .Columns("A").Delete
        .Select
    End With

    Application.ScreenUpdating = True

    MsgBox "統合完了"

 End Sub

 (ぶらっと)

ぶらっと様

ありがとうございます。
早速試させていただきました。
バッチリでした。感動です。
私も勉強して早くコードが書けるように頑張りますので、また、解らないことが
ありましたらよろしくお願いいたします。

また、mook様もご教示いただきましてありがとうございました。
（さおり）

コメント返信：

[ 一覧(最新更新順) ]

[[20130517140530]] 『初心者のため、お知恵を借りたくてここに来ました。どなたかご教示願えればありがたいです。 ページの最後に飛ぶ

[[20130517140530]]　『初心者のため、お知恵を借りたくてここに来ました。どなたかご教示願えればありがたいです。　ページの最後に飛ぶ