複数の調査票(エクセル)の集約

Question

エクセルで調査票を作成しました。
複数部署からその調査票で回答が来るため、回答を集約するマクロを作成しているのですが、
ループの部分がおかしいようで、いくつかの問題が生じています。

①各調査票の5行目以降の回答ではなく、「5行目＋前の調査票の回答行」番目の行を集約してきてしまいます。
②各調査票の右端の、最終列の項目まで取得したいのに、取得できません。
③各調査票について、集約のマクロを起動すると、すべての調査票が開き、「●●エクセルに変更を加えます」とポップアップが出てしまいます。単純に回答列だけ集約したいので、変更は入らないようにしたいです。

修正したいので、お力を貸してください。

Public Sub MainProc()
    Dim shtMain As Worksheet
    Dim folderPath As String
    Dim shtName As String
    Dim dataStartRow As Long
    Dim nowRow As Long
    Dim shtTaisyo As Worksheet
    Dim shtSyuyaku As Worksheet
    Dim ext As String
    Dim wb As Workbook
    Dim lastRow As Long
    Dim lastCol As Long
    Dim fso As Object
    Dim f As Object
    
    '①「メイン」シートを変数に格納する
    Set shtMain = ThisWorkbook.Sheets("メイン")
    
    '②対象フォルダを変数に格納する
    folderPath = shtMain.Range("A2")
    
    '③シート名を変数に格納する
    shtName = shtMain.Range("B2")
    
    '④データ開始行を変数に格納する
    dataStartRow = shtMain.Range("C2")
    
    '⑤集約データ開始行を変数に格納する
    nowRow = shtMain.Range("D2")
            
    '⑥「集約データ」シートを変数に格納する
    Set shtSyuyaku = ThisWorkbook.Sheets("集約データ")
            
    '⑦「集約データ」シートの開始行以下をクリアする
    shtSyuyaku.Rows(nowRow & ":" & shtSyuyaku.Rows.Count).Clear
    
    '⑧FileSystemObjectを変数に格納する
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    '⑨対象フォルダに存在するファイル数分処理する
    For Each f In fso.GetFolder(folderPath).Files
        
        '⑩ファイルの拡張子を変数に格納する
        ext = LCase(fso.getextensionName(f.Name))
        
        '⑪拡張子が「xlsx」のみ処理を行う
        If ext = "xlsx" Then
        
            '⑫対象ブックを開く
            Set wb = Workbooks.Open(folderPath & "\" & f.Name)
            
            '⑬対象シートを変数に格納する
            Set shtTaisyo = wb.Sheets(shtName)
            
            '⑭対象シートの最終行を取得する
            lastRow = shtTaisyo.Cells(shtTaisyo.Rows.Count, 1).End(xlUp).Row
            
            '⑮対象シートの最終列を取得する
            lastCol = shtTaisyo.Cells(1, shtTaisyo.Columns.Count).End(xlToLeft).Column
            
            '⑯対象シートの対象データを集約シートにコピーする
            shtTaisyo.Range(shtTaisyo.Cells(dataStartRow, 1), shtTaisyo.Cells(lastRow, lastCol)).Copy _
                            (shtSyuyaku.Cells(nowRow, 1))
            
            '⑰次の貼り付け行を計算する
            nowRow = nowRow + lastRow - (dataStartRow - 1)
            
            '⑱対象ブックを閉じる
            wb.Close
            
            '⑲メモリを解放する
            Set wb = Nothing
            
        End If
    Next
    
    MsgBox "完了"
End Sub

Answer 1

とりあえずこんな感じでどうでしょうか。

            '⑭対象シートの最終行を取得する
            lastRow = shtTaisyo.Cells(shtTaisyo.Rows.Count, 1).End(xlUp).Row

            '⑮対象シートの最終列を取得する
            lastCol = shtTaisyo.Cells(dataStartRow, shtTaisyo.Columns.Count).End(xlToLeft).Column

            '⑯対象シートの対象データを集約シートにコピーする
            Dim rng As Range
            Set rng = shtTaisyo.Range(shtTaisyo.Cells(dataStartRow, 1), shtTaisyo.Cells(lastRow, lastCol))
            Debug.Print rng.Address
            
            shtSyuyaku.Cells(nowRow, 1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
            
            '⑰次の貼り付け行を計算する
            nowRow = nowRow + rng.Rows.Count
            
            '⑱対象ブックを閉じる
            wb.Close False
            

Comments

[natori]

解決しました！ありがとうございました。