エクセル複数ファイルを一つのシートに…

別の質問で、行ごとに合成するVBAを紹介しましたので、それを１列ごとに合成するようになおしました。 '条件：(1)任意のフォルダの中に、合成したいすべてのエクセルファイルを入れる。各ファイルの名前は異なっていること。 '　　　(2)各エクセルファイルの中の「練習」シートの１列目に同じ形式でデータが入れてあるとする。 '　　　(3)集計は「Main.xls」の「練習」シートに順にくっつけていく。 '　　　(4)コード中の「シート名」は自由に変更してください。 '　　　(5)Main.xlsについては、シートが２つ「search」「練習」が必要です。「search」シートはフォルダの '　　　　場所と、その中のファイルの名前を取得して一覧にしています。その後、そのファイル名を使って '　　　　「練習」シートに各ファイルの「練習」シートのデータを合成しました。 '　　　(6)このコードは、「ツール」「マクロ」「VisualBasicEditor」でエディター画面を開き、 '　　　　「挿入」「Module1」の所にはりつけ,エクセル画面で「ツール」「マクロ」「マクロ」 '　　　　「FileSearchの実行」で動かす。 Sub FileSearch(): 'ファイル検索 Dim sfolda As String Dim SName As String Dim i, j, k, n As Integer Dim ww As String Dim L, S As Integer Dim ws As Object Dim DName As String Dim PP, FF As String Dim MaxG, DKoumoku, DLine As Integer Dim MaxFileSu As Integer '各値初期設定 MaxFileSu = 100: '最大ファイル数 DName = "練習": 'シート名 MaxG = 1000: '最大検索行数 DLine = 1: 'データ入力行数カウント Application.ScreenUpdating = False '現在のフォルダのパスを設定 sfolda = ThisWorkbook.Path 'ファイル名を入れるシートをセットおよび初期化 Set ws = Workbooks("Main.xls").Worksheets("search") ws.Range("B1").ClearContents ws.Range("A4:B200").ClearContents ws.Cells(1, 2).Value = sfolda '各ファイル名を検索しsearchシートに登録 SName = "*.xls" n = 1 With Application.FileSearch .LookIn = sfolda .Filename = SName rs1 = .Execute If rs1 = 0 Then Exit Sub For Each nm In .FoundFiles ww = nm S = 1 While S > 0 S = InStr(1, ww, "\", 1) L = Len(ww) ww = Right(ww, L - S) Wend If ww <> "Main.xls" Then ws.Cells(n + 3, 1).Value = n: '１列目に番号セット ws.Cells(n + 3, 2).Value = ww: '２列目にファイル名セット n = n + 1 End If Next nm End With '====================================================================== '合成処理 For n = 1 To MaxFileSu 'ファイル名をセット PP = ws.Cells(1, 2).Value If ws.Cells(n + 3, 2).Value = "" Then Exit For FF = ws.Cells(n + 3, 2).Value PP = PP & "\" & FF 'ファイルオープン Workbooks.Open (PP) '各シートからデータをMainに追加貼り付け For i = 1 To MaxG If Workbooks(FF).Worksheets(DName).Cells(i, 1).Value = "" Then Exit For Else Workbooks("Main.xls").Worksheets(DName).Cells(i, DLine).Value = Workbooks(FF).Worksheets(DName).Cells(i, 1).Value End If Next i DLine = DLine + 1 'ファイルクローズ Workbooks(FF).Close Next n End Sub