Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(指定なし : 指定なし)
別ブックのシートを参照し、1つにデータをまとめたい
投稿日時: 21/02/12 11:16:33
投稿者: moco

こんにちは。VBA初心者で複数の条件が重なると複雑で分からなくなってしまいました。
 
やりたいことは、
 1、ファイルを選ぶ OpenFileName = Application.GetOpenFilename("Excelファイル,*.xls*")
 2、開いたExcelブックに「内訳」「内訳(2)」・・・と複数のシートがある場合
   マクロを実行しているファイルの「内訳シート」に1つに集約したい。
  
 開いたファイルの「内訳」のシートはすべてA7:F42の範囲にデータがあるので、それを
1つに集約したい「内訳シート」の2行目から順番にコピーしたいと思っています。
 
 同じブック内のシートを1つにまとめるのは他のサイトで見つけたのですが、別ブックのものを
1つにまとめるところが分からず困っています。
 
分かる方、よろしくお願いいたします。

回答
投稿日時: 21/02/12 14:21:12
投稿者: simple

>同じブック内のシートを1つにまとめるのは他のサイトで見つけた
そこまではわかるということでしたら、それを示してください。

投稿日時: 21/02/12 15:21:58
投稿者: moco

下記のように作成しているのですが、変数宣言すらよく理解できておらず実行できません。
どなたか、アドバイス頂ければ幸いです。
 
Sub 直工内訳Kシート作成()
    Dim OpenFileName As String
    trgtShName = "直工内訳K"
 
    Dim sWS As Workbook '中間ファイルブック
    Dim dWS As Workbook '参照ブック
    Dim flag As Boolean 'シートが開いているかどうかのフラグを定義する
    Dim wstData As Worksheet '中間ファイル「直工内訳K」用オブジェクト変数
    Dim wstAnsw As Worksheet '参照ブックの各シートの入力データ用オブジェクト変数
    Dim r As Long
     
    '入力したいExcelファイルを選ぶ
    OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
     
    'キャンセル時の処理
    If OpenFileName = "False" Then
        'メッセージ表示
        MsgBox "キャンセルされました。処理を終了します。"
        End
    Else
        Workbooks.Open OpenFileName
    End If
 
 
 ※ ここから先が分からず困っています。
     
    For Each sWS In ThisWorkbook.Worksheets
             
        If dWS.Name Like "*" & trgtShName & "*" Then 'シートの名前に直行内訳という名前があれば
             
            flag = True 'フラグをTrueにする
                 
            Exit For
        End If
             
     Next sWS
         
        If flag = True Then
             
            Set sWS = ThisWokbook.Worksheets("直工内訳K")
    
                 
                '「Data」シート初期化
            With wstData
                 .Rows("2:" & .Rows.Count).ClearContents
            End With
     
            lngWRow = 2 '初期化に伴い書込行も2へリセット
     
                 
            'すべてのワークシートを繰り返し処理
            For Each wstAnsw In Worksheets
                With wstAnsw
                     If .Name <> "内訳" Then 'シート名が「Data」を除く場合
                        For r = 7 To 42 '直工内訳Kシートの7行目から42行目までのレコードを読み取る処理
                            If .Cells(r, 1) <> "" Then '記載がある場合
                                wstData.Cells(lngWRow, 1) = .Cells(r, 1) '名称A列
                                wstData.Cells(lngWRow, 2) = .Cells(r, 2) '名称B列
                                wstData.Cells(lngWRow, 3) = .Cells(r, 3) '名称C列
                                wstData.Cells(lngWRow, 4) = .Cells(r, 4) '摘要
                                wstData.Cells(lngWRow, 5) = .Cells(r, 5) '金額
                                wstData.Cells(lngWRow, 6) = .Cells(r, 6) '備考
                         
                                lngWRow = lngWRow + 1 '書込み行を次の行へ進める
 
                            ElseIf .Cells(r, 42) = "" Then 'シート名が空欄の場合
                                Exit For '読み取りを終了
                            End If
                         Next
                      End If
                End With
            Next
        End If
End Sub

回答
投稿日時: 21/02/12 19:22:51
投稿者: simple

うーむ、見本とするものが余り適切じゃない気がしますね。
 
こんな感じのものに手を入れてみては、どうですか。
(完成品じゃありませんので、そちらで加工ないし修正してください。)
 

Sub test()
    Dim OpenFileName As String

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim tWs As Worksheet    '転記先シート(destination worksheet)
    Dim rng As Range        '転記先の開始行のA列セル
    
    OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")

    'キャンセル時の処理
    If OpenFileName = "False" Then
        'メッセージ表示
        MsgBox "キャンセルされました。処理を終了します。"
        End
    Else
        Set wb = Workbooks.Open(OpenFileName)
    End If

    Set tWs = ThisWorkbook.Worksheets("内訳シート")

    For Each ws In wb.Worksheets
        If ws.Name Like "内訳" & "*" Then
            Set rng = tWs.Cells(Rows.Count, "A").End(xlUp).Offset(1)

            'wsの転記元セルを rng にコピーする(ここはあなたが書いてください)
        
        End If
    Next
    
    wb.Close False
End Sub

【補足】
1. コピー先の最初のセルを指定してコピーすれば、矩形領域がコピーペイストされるはずです。
2.コピーペイストの種類は状況によります。そちらで判断してください。
   ・単純なコピーペースト
   ・値のみ複写
   ・値と書式の複写
なお、上記のコードは検証していないので、そちらで確認のうえ使ってください。

回答
投稿日時: 21/02/12 19:26:48
投稿者: simple

こちらのサイトの「即効テクニック」というTips集も探してみるといいですよ。
 
シート操作関連のテクニック
「複数のシートのデータを1つのシートにコピーする」
https://www.moug.net/tech/exvba/0040062.html

投稿日時: 21/02/13 11:31:48
投稿者: moco

ご回答ありがとうございました。
かなりの初心者ですので、昨晩は
Set rng = tWs.Cells(Rows.Count, "A").End(xlUp).Offset(1)
 
の箇所を勉強して、今朝、アドバイスを基に作成して動くようになりました。
本当に助かりました。
情報も頂き、ありがとうございました。