Excel VBA質問箱 IV

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

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


38 / 13057 ツリー ←次へ | 前へ→

【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 お礼[未読]

【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


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

【79355】Re:複数ブック・複数シートから1行コピー...
発言  マナ  - 17/9/3(日) 14:07 -

引用なし
パスワード
   ▼sakura さん:

こんな感じで、開いたブックについて
For Each〜Nextでループし、シート名を確認しながら
転記するようにしてはどうですか。


Set wb = Workbooks.Open(TotalDir & "\" & TargetFile)
For Each ws In wb.Worksheets
  If ws.Name Like "Sheet*" Then

【79359】Re:複数ブック・複数シートから1行コピー...
質問  sakura  - 17/9/4(月) 9:57 -

引用なし
パスワード
   マナさん
ありがとうございます&#8252;
無知でお恥ずかしい限りですが、どこにどのように組み込めば良いかがわかりません…
自分なりにやると、コンパイルエラーになってしまいました。
引き続きアドバイスをお願いできますでしょうか&#8264;
よろしくお願いいたしますm(__)m

【79360】Re:複数ブック・複数シートから1行コピー...
発言  マナ  - 17/9/4(月) 19:36 -

引用なし
パスワード
   ▼sakura さん:

>自分なりにやると、コンパイルエラーになってしまいました。

どのようにしたか、教えてください。

【79362】Re:複数ブック・複数シートから1行コピー...
質問  sakura  - 17/9/5(火) 12:11 -

引用なし
パスワード
   おそらく、かなりおなしなことをしてしまっているだろうと思い、自分なりに…の部分を割愛させていただきましたが…
恥をしのんで、、
下記のように、もとのコードの59行目の Set wh = Workbooks… の部分を、教えていただいたコードに置き換えました。
また、25行目+指定している TargetSheet もこのままではダメかな&#8264;と思い、コメントにしています。
お手数をおかけして申し訳ありませんが、もしよろしければ、どこをどう変更すれば良いか、までお教えいただけると大変助かります。
勉強不足で大変恐縮です。。
よろしくお願いいたしますm(__)m


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:\Users\NS26517\OneDrive - Teijin-Frontier\201708法務審査_下請調査関係\アンケート集計"

  ' 集計対象シートの指定
  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)
      For Each ws In wb.Worksheets
        If ws.Name Like "Sheet*" Then
      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

【79363】Re:複数ブック・複数シートから1行コピー...
発言  マナ  - 17/9/5(火) 20:18 -

引用なし
パスワード
   ▼sakura さん:

すべてのシートで処理をさせる構文は、

For Each ws In wb.Worksheets
  ここに処理内容
Next

-------
条件を満たした場合のみ処理する構文は、

If 条件 Then
  ここに処理内容
End If

-------
で、こうすると
Sheetで始まるシートのみ処理できます。

For Each ws In wb.Worksheets
  If ws.Name Like "Sheet*" Then
    LastRow = tb.Sheets(TotalSheet).Rows(Rows.Count).End(xlUp).Row + 1
 
    ' 行ごとのコピーを行うとなぜかずれるので値のみコピーしてみる。
    ws.Rows(TargetRow).Copy
    tb.Sheets(TotalSheet).Rows(LastRow).PasteSpecial (xlPasteValues)
  End If
Next

-------
あとは、

>TargetSheet = "Sheet1"
これを

TargetSheet = "Sheet*"
に変更すれば

>If ws.Name Like "Sheet*" Then
は、

If ws.Name Like TargetSheet Then
にするとよいです。

【79367】Re:複数ブック・複数シートから1行コピー...
お礼  sakura  - 17/9/6(水) 17:05 -

引用なし
パスワード
   マナさん、できました&#8252;
ご親切に、本当にありがとうございましたm(__)m
とっても助かりました&#8252;
これを機に、自分でも書けるように勉強してみたいと思います。
ありがとうございましたm(__)m

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