Excel VBA質問箱 IV

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

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


22 / 13041 ツリー ←次へ | 前へ→

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

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

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

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

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

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

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

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

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