[[20160627142306]]　『同一フォルダ内にある全てのファイルを、一つのシ』（q10）　ページの最後に飛ぶ

『同一フォルダ内にある全てのファイルを、一つのシートにまとめる方法』（q10）

下記のコードは、A1に値があった場合A～Nまでをコピペするものですが
コピー元"調査票"シートの張り付けたい値がさまざまなセルにあります。
例えば
　"調査票"シート　C7セル　→　"統括表"ブック"進行表のB列"
　"調査票"シート　C8セル　→　"統括表"ブック"進行表のC列"
　"調査票"シート　K7セル　→　"統括表"ブック"進行表のE列"
　"調査票"シート　K11セル　→　"統括表"ブック"進行表のF列"
　　等・・・

という様に書き換えるにはどうしたら良いでしょうか。
ご教授よろしくお願いします。

Sub Sample()
Dim t As Single
Dim strPath As String
Dim strFileName As String
Dim WB1 As Workbook
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim lngRowCount As Long 'A列に値が入っているデータ数

t = Timer

Set WS2 = ThisWorkbook.Worksheets(1)
strPath = ThisWorkbook.Path
strFileName = Dir(strPath & "\*.xls*")
Do While strFileName <> ""
If strFileName <> ThisWorkbook.Name Then
Set WB1 = Workbooks.Open(strPath & "\" & strFileName)
Set WS1 = WB1.Worksheets(1)
With WS1.Range("A1")
lngRowCount = .Worksheet.Cells(.Worksheet.Rows.Count, .Column).End(xlUp).Row - .Row
If lngRowCount >= 1 Then

With .Resize(lngRowCount, 14).Offset(1) 'N列まで
.Copy WS2.Range("A" & WS2.Rows.Count).End(xlUp).Offset(1)
End With

End If
End With
WB1.Close False
End If
strFileName = Dir
Loop

End Sub

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

 Sub Sample()
    Dim strPath As String
    Dim strFileName As String
    Dim WS2 As Worksheet
    Dim iR As Long

    Application.ScreenUpdating = False
    iR = 1

    Set WS2 = ThisWorkbook.Worksheets(1)
    strPath = ThisWorkbook.Path
    strFileName = Dir(strPath & "\*.xls*")

    Do While strFileName <> ""
        If strFileName <> ThisWorkbook.Name Then
            With Workbooks.Open(strPath & "\" & strFileName)
                With .Sheets(1)
                    iR = iR + 1
                    WS2.Cells(iR, "B").Value = .Range("C7")
                    WS2.Cells(iR, "C").Value = .Range("C8")
                    WS2.Cells(iR, "E").Value = .Range("K7")
                    WS2.Cells(iR, "F").Value = .Range("K11")
                End With
                .Close False
            End With
        End If
        strFileName = Dir
    Loop

    Application.ScreenUpdating = True
 End Sub
（???） 2016/06/27(月) 14:58

コメント返信：

[ 一覧(最新更新順) ]

[[20160627142306]] 『同一フォルダ内にある全てのファイルを、一つのシ』（q10） ページの最後に飛ぶ

[[20160627142306]]　『同一フォルダ内にある全てのファイルを、一つのシ』（q10）　ページの最後に飛ぶ