質問編集履歴

修正しました。

2019/09/25 09:05

投稿

cjapan35

スコア10

test CHANGED Viewed

File without changes

test CHANGED Viewed

@@ -33,423 +33,3 @@
 " LastRw2 = wbk_new.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row "
 のところで表示されます。
-### 該当のソースコード
-```VBA
-Option Explicit
-Private writeRowIndex       As Long
-Private trgWorkSheet        As Worksheet
-Private rootPath        As String
-Private wbk As Workbook
-Private wbk_new As Workbook
-Private workBookName As String
-'-----------------------------------------------------------------------
-' ファイルの集計
-'-----------------------------------------------------------------------
-Public Sub ファイルをまとめる()
-    Application.DisplayAlerts = False
-    Application.ScreenUpdating = False
-    Dim trgPath As String
-    '-- ファイルのあるフォルダを選択
-    With Application.FileDialog(msoFileDialogFolderPicker)
-        If .Show = True Then
-            trgPath = .SelectedItems(1)
-        End If
-If trgPath = "" Then
-            Application.ScreenUpdating = True
-            Application.DisplayAlerts = True
-            Exit Sub
-        End If
-    End With
-    writeRowIndex = 2
-      Set wbk = ActiveWorkbook
-        '-- 結果ブック作成
-        Set wbk_new = Workbooks.Add()
-        workBookName = "ファイル_集約"
-        '-- ファイルを開く
-        Set wbk_new = Workbooks.Open(workBookName, 0)
-        Set trgWorkSheet = wbk_new.Sheets(1)
-        trgWorkSheet.Name = "集約"
-        '-- 結果ブックに名前を付けて保存
-        wbk_new.SaveAs (workBookName)
-        '-- 結果ブックを閉じる
-        wbk_new.Close savechanges:=True
-'-- 再帰的に全部のファイルを処理する
-    Dim objFSO As FileSystemObject
-    Dim strPATHNAME As String
-    strPATHNAME = trgPath
-    Set objFSO = New FileSystemObject           ' FSO
-    ' ルートフォルダから探索開始
-    Call SEARCH_SUB_FOLDER(objFSO.GetFolder(strPATHNAME))
-' 参照OBJECTを破棄
-    Set objFSO = Nothing
-    '-- 書式をコピー
-    Dim r       As Long
-    If (writeRowIndex <> 2) Then
-        trgWorkSheet.Rows(2).Copy
-        For r = 2 + 1 To writeRowIndex
-            trgWorkSheet.Rows(r).PasteSpecial (xlPasteFormats)
-        Next
-        Application.CutCopyMode = False
-    End If
-    Set trgWorkSheet = Nothing
-    ' 処理完了(結果表示)
-    Application.ScreenUpdating = True
-    Application.DisplayAlerts = True
-    MsgBox "終了"
-End Sub
-'-- 再帰用
-Private Sub SEARCH_SUB_FOLDER(ByVal objPATH As Folder)
-    Dim objPATH2 As Folder
-    Dim objFILE As File
-    ' ■先ずサブフォルダを探索するループ処理
-    For Each objPATH2 In objPATH.SubFolders
-        ' フォルダ単位のサブ処理(再帰呼び出し)
-        Call SEARCH_SUB_FOLDER(objPATH2)
-    Next objPATH2
-    For Each objFILE In objPATH.Files
-        If InStr(objFILE.Type, "Excel") <= 0 Or InStr(objFILE.Name, "ファイル") <= 0 Then
-            GoTo NextLoop
-        End If
-        '-- ファイルを開く
-        Set wbk = Workbooks.Open(objFILE.Path, 0)
-        '-- データの集計
-        Call Get集約(wbk)
-        wbk_new.SaveAs (workBookName)
-        '-- 保存せずにブックを閉じる
-        wbk.Close savechanges:=False
-NextLoop:
-        '-- オブジェクトの破棄
-        Set wbk = Nothing
-    Next objFILE
-    ' 参照OBJECTを破棄
-    Set objPATH = Nothing
-End Sub
-'-- 実際にシートを舐めながらヘッダ情報を採取する
-Private Sub Get集約(ByRef wbk As Workbook)
-    Dim wkst        As Worksheet
-    Dim sh          As Worksheet
-    Dim batchID     As String
-    Dim j As Integer
-    Dim bol_copy As Boolean
-    Dim bol_IsData As Boolean
-    Const checkColCnt As Integer = 4
-    '-- ヘッダ書き出し用のシートを対象に設定する
-    Set wkst = trgWorkSheet
-    j = 1
-    '-- 項目定義のヘッダを取得
-    Dim rowCnt As Long
-    Dim colCnt As Long
-    For Each sh In wbk.Sheets
-        bol_copy = False
-        bol_IsData = False
-        Dim i As Integer
-        If (InStr(1, sh.Name, "SD") > 0) Then
-            rowCnt = 5
-    Dim LastRw1 As Long '元データの最終行
-    Dim LastRw2 As Long '新規ブックの最終行
-            wbk.Activate
-            '元データの最終行を取得
-            LastRw1 = wbk.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
-            '新規ブックの最終行を取得
-            LastRw2 = wbk_new.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
-            If LastRw1 >= 2 Then
-            Range(Rows(2), Rows(LastRw1)).Copy Destination:=wbk_new.Sheets(1).Cells(LastRw2 + 1, 1)
-            End If
-        End If
-    Next
-End Sub
-```
-現在やろうとしていることは、以前までのコードだと一つ目のブックの表を貼り付けた後に二つ目のブックの表をそのまま上書きで貼り付けてしまっていたので、1つ目の表の1行下に次の表を貼り付けるというやり方をしたいのですが、エラーも出てうまくいきません。
-修正箇所であったり、何か別の適切なコードがあればそちらを教えていただきたいです。
-ちなみに以下が以前までのコードです。
-```
-sh.Range("R" & i).MergeCells = False
-sh.Columns("A:R").Copy
-wkst.Rows(j).PasteSpecial
-```
-現コードの"Dim LastRw1 As Long '元データの最終行"から"End If"の間にこのコードを入れていたときは、エラーは出なかったものの、表を上書きで貼り付けてしまっていました。
-よろしくお願いします。