Excel VBA質問箱 IV

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

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


93 / 73808 ←次へ | 前へ→

【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


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

43 hits

【79354】複数ブック・複数シートから1行コピーしてまとめたい sakura 17/9/3(日) 0:05 質問[未読]
【79355】Re:複数ブック・複数シートから1行コピーし... マナ 17/9/3(日) 14:07 発言[未読]
【79359】Re:複数ブック・複数シートから1行コピーし... sakura 17/9/4(月) 9:57 質問[未読]
【79360】Re:複数ブック・複数シートから1行コピーし... マナ 17/9/4(月) 19:36 発言[未読]
【79362】Re:複数ブック・複数シートから1行コピーし... sakura 17/9/5(火) 12:11 質問[未読]
【79363】Re:複数ブック・複数シートから1行コピーし... マナ 17/9/5(火) 20:18 発言[未読]
【79367】Re:複数ブック・複数シートから1行コピーし... sakura 17/9/6(水) 17:05 お礼[未読]

93 / 73808 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free