Option Explicit
 
Public Sub アンケート集計()
    Const Folder As String = "D:\goo\data7"     'excelファイル格納フォルダ
    Dim fname   As String   'ファイル名
    Dim wb2 As Workbook     '記入表のブック
    Dim ws1 As Worksheet    '回答一覧
    Dim ws2 As Worksheet    '記入表
    Dim maxrow As Long      '回答一覧の最大行
    Dim row1 As Long        '回答一覧の処理行
    Set ws1 = Worksheets("回答一覧")
    maxrow = ws1.Cells(Rows.Count, "C").End(xlUp).Row    'C列の最大行取得
    If maxrow < 2 Then maxrow = 2       '2行未満なら2行に修正
    row1 = maxrow + 1                   'maxrowの次の行から書き込み
    fname = Dir(Folder & "\*.xlsx")      '指定フォルダ内の*.xlsxを取得
    If fname = "" Then
        MsgBox (Folder & "内に.xlsxなし")
        Exit Sub
    End If
    Do While fname <> ""
        '該当ファイルをオープン
        Set wb2 = Workbooks.Open(Folder & "\" & fname)
        Set ws2 = wb2.Worksheets("記入表")
        '記入表から回答一覧へ６セル分まとめて転記
        ws1.Cells(row1, "C").Resize(, 6).Value = ws2.Cells(3, "C").Resize(, 6).Value
        wb2.Close SaveChanges:=False
        '回答一覧の処理行に1加算
        row1 = row1 + 1
        '次のexcelファイルを取得
        fname = Dir()
    Loop
    MsgBox ("処理完了")
End Sub
 

T3B0aW9uIEV4cGxpY2l0CgpQdWJsaWMgU3ViIOOCouODs+OCseODvOODiOmbhuioiCgpCiAgICBDb25zdCBGb2xkZXIgQXMgU3RyaW5nID0gIkQ6XGdvb1xkYXRhNyIgICAgICdleGNlbOODleOCoeOCpOODq+agvOe0jeODleOCqeODq+ODgAogICAgRGltIGZuYW1lICAgQXMgU3RyaW5nICAgJ+ODleOCoeOCpOODq+WQjQogICAgRGltIHdiMiBBcyBXb3JrYm9vayAgICAgJ+iomOWFpeihqOOBruODluODg+OCrwogICAgRGltIHdzMSBBcyBXb3Jrc2hlZXQgICAgJ+WbnuetlOS4gOimpwogICAgRGltIHdzMiBBcyBXb3Jrc2hlZXQgICAgJ+iomOWFpeihqAogICAgRGltIG1heHJvdyBBcyBMb25nICAgICAgJ+WbnuetlOS4gOimp+OBruacgOWkp+ihjAogICAgRGltIHJvdzEgQXMgTG9uZyAgICAgICAgJ+WbnuetlOS4gOimp+OBruWHpueQhuihjAogICAgU2V0IHdzMSA9IFdvcmtzaGVldHMoIuWbnuetlOS4gOimpyIpCiAgICBtYXhyb3cgPSB3czEuQ2VsbHMoUm93cy5Db3VudCwgIkMiKS5FbmQoeGxVcCkuUm93ICAgICdD5YiX44Gu5pyA5aSn6KGM5Y+W5b6XCiAgICBJZiBtYXhyb3cgPCAyIFRoZW4gbWF4cm93ID0gMiAgICAgICAnMuihjOacqua6gOOBquOCiTLooYzjgavkv67mraMKICAgIHJvdzEgPSBtYXhyb3cgKyAxICAgICAgICAgICAgICAgICAgICdtYXhyb3fjga7mrKHjga7ooYzjgYvjgonmm7jjgY3ovrzjgb8KICAgIGZuYW1lID0gRGlyKEZvbGRlciAmICJcKi54bHN4IikgICAgICAn5oyH5a6a44OV44Kp44Or44OA5YaF44GuKi54bHN444KS5Y+W5b6XCiAgICBJZiBmbmFtZSA9ICIiIFRoZW4KICAgICAgICBNc2dCb3ggKEZvbGRlciAmICLlhoXjgasueGxzeOOBquOBlyIpCiAgICAgICAgRXhpdCBTdWIKICAgIEVuZCBJZgogICAgRG8gV2hpbGUgZm5hbWUgPD4gIiIKICAgICAgICAn6Kmy5b2T44OV44Kh44Kk44Or44KS44Kq44O844OX44OzCiAgICAgICAgU2V0IHdiMiA9IFdvcmtib29rcy5PcGVuKEZvbGRlciAmICJcIiAmIGZuYW1lKQogICAgICAgIFNldCB3czIgPSB3YjIuV29ya3NoZWV0cygi6KiY5YWl6KGoIikKICAgICAgICAn6KiY5YWl6KGo44GL44KJ5Zue562U5LiA6Kan44G477yW44K744Or5YiG44G+44Go44KB44Gm6Lui6KiYCiAgICAgICAgd3MxLkNlbGxzKHJvdzEsICJDIikuUmVzaXplKCwgNikuVmFsdWUgPSB3czIuQ2VsbHMoMywgIkMiKS5SZXNpemUoLCA2KS5WYWx1ZQogICAgICAgIHdiMi5DbG9zZSBTYXZlQ2hhbmdlczo9RmFsc2UKICAgICAgICAn5Zue562U5LiA6Kan44Gu5Yem55CG6KGM44GrMeWKoOeulwogICAgICAgIHJvdzEgPSByb3cxICsgMQogICAgICAgICfmrKHjga5leGNlbOODleOCoeOCpOODq+OCkuWPluW+lwogICAgICAgIGZuYW1lID0gRGlyKCkKICAgIExvb3AKICAgIE1zZ0JveCAoIuWHpueQhuWujOS6hiIpCkVuZCBTdWIK