Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

3020 / 76735

←次へ　｜　前へ→


	【79354】複数ブック・複数シートから1行コピーしてまとめたい

sakura - 17/9/3(日) 0:05 -


	引用なし

	パスワード

教えてください。
環境は、Windows10 Enterprise　（ビルド1607）　Excel2016　です。
1つのフォルダに100を超える数のエクセルブックがあり、それぞれのブックの中には複数のワークシートがあります。
全ブックから、シート名に　「Sheet」　と付くワークシート（Sheet1・Sheet10など）の2行目だけを抜き出して、別の集計用ブックにまとめるマクロを作成する必要があります。
前任者が作成したvbaで、複数ブックの　「Sheet1」　の2行目だけを抜き出すマクロはあるのですが、これをアレンジしてなんとかならないでしょうか？

Sub アンケート集計実行()
　　Dim wbn As Workbook
　　Dim wb As Workbook
　　Dim tb As Workbook
　　Dim TotalDir As String
　　Dim TotalSheet As String
　　Dim TargetSheet As String
　　Dim TargetFile As String
　　Dim TargetRow As String
　　Dim StartRow As String
　　Dim LastRow As String
　　Dim modeFlag As Boolean
　
'====================================================
'　　　　　　　　　　　値の設定
'====================================================
　
　　' 集計対象フォルダの指定
　　TotalDir = "C:\アンケート集計"

　　' 集計対象シートの指定
　　TargetSheet = "Sheet1"
　　　
　　' 集計用シートの指定
　　TotalSheet = "集計"
　　　
　　' 集計対象行の指定
　　TargetRow = "2"
　
　　' 集計結果記載開始行を指定
　　StartRow = "2"
　
　　' 追記するかしないかフラグ(True : 追記する、False: 追記しない)
　　modeFlag = False

'====================================================
'　　　　　　　　　　　実処理
'====================================================
　　Set tb = ThisWorkbook
　
　　If modeFlag = False Then
　　　　　　LastRow = tb.Sheets(TotalSheet).Rows(Rows.Count).End(xlUp).Row + 1
　　　　　　tb.Sheets(TotalSheet).Range(StartRow & ":" & LastRow).Delete
　　End If
　　　
　　TargetFile = Dir(TotalDir & "\*.xlsx", vbNormal)
　　Do While TargetFile <> ""
　　　　If TotalDir & "\" & TargetFile <> TotalFile Then
　　　　　　For Each wbn In Workbooks
　　　　　　　　If wbn.Name = TargetFile Then
　　　　　　　　　　MsgBox TargetFile & " は、既に開かれています。" & vbCrLf & "集計処理を中止します。"
　　　　　　　　　　Exit Sub
　　　　　　　　End If
　　　　　　Next wbn
　　　　　　Set wb = Workbooks.Open(TotalDir & "\" & TargetFile)
　　　　　　LastRow = tb.Sheets(TotalSheet).Rows(Rows.Count).End(xlUp).Row + 1
　
　　　　　　' 行ごとのコピーを行うとなぜかずれるので値のみコピーしてみる。
　　　　　　wb.Sheets(TargetSheet).Rows(TargetRow).Copy
　　　　　　tb.Sheets(TotalSheet).Rows(LastRow).PasteSpecial (xlPasteValues)
　　　　　
　　　　　　' クリップボード警告対策
　　　　　　tb.Sheets(TotalSheet).Range("A1").Copy
　　　　　
　　　　　　' 集計対象ファイルを閉じる
　　　　　　wb.Close False

　　　　End If
　　　
　　　　TargetFile = Dir()
　　Loop
　
　　' クリップボード警告対策
　　tb.Sheets(TotalSheet).Range("A1").Copy
　
　　' 集計ファイルを保存
　　tb.Save

　　' 集計後のファイルを閉じる
　　' tb.Close True
　
　　' 完了を通知
　　MsgBox "集計を完了しました。"
End Sub

あるいは、別の方法でも結構ですので、お知恵をお貸しいただけますと幸いです。
どうぞよろしくお願いいたします。

1 hits

▼

【79354】複数ブック・複数シートから1行コピーしてまとめたい sakura 17/9/3(日) 0:05