ID非公開

2022/7/5 18:14

11回答

VBAに関する質問です。 少しややこしい作業であり、拙い文章ですがよろしくお願いします。 ・現在の手作業

VBAに関する質問です。 少しややこしい作業であり、拙い文章ですがよろしくお願いします。 ・現在の手作業 各拠点(30-40拠点で毎期変動)から受領したエクセルブック(A報告書と呼びます)のD11セル〜W39セルをコピーして、全体まとめブック(B報告書)の各拠点のシートのD13セル〜W41セルに貼るという作業を1ヶ月に1回行っており、こちらのマクロを作成したいと考えております。 A報告書について ・シートの構成は1シートのみで、シート名はsheet1となっています。 ・拠点には4桁の番号(1000〜8000でランダム)が設定されており、A報告書はそれぞれ、『234500_計数報告.xls』のようにブック名の頭4桁で営業店の判別ができるようになっております。00に特に意味はないようですが全てのブックに記載があります。 ・集まったA報告書は全て同一のフォルダに自動で格納されております。(その後ブックの移動は可能ですが、ブック名の変更は不可です) ・A報告書は該当がある場合のみ報告されるため、必ず報告があるわけではなく、月によっては上記フォルダに保存されない場合があります。 ・A報告書のL2セルにはその拠点の4桁の番号(2345等)が入力されています。 B報告書について ・シートの構成は、2シート目から4シート目は注意書きがあるだけです。 ・5シート目から最後のシートに、各拠点のシートがあります。シート名は営業店の4桁の番号(2345等)で、営業店が増える度にシートを追加しております。 ・各拠点のシートのB2セルには拠点の4桁の番号が入力されています。 ・1シート目には5シート目以降の計数を合計できる関数が組まれています。 ・やりたいこと フォルダ内のA報告書全てについて、A報告書のL2セルとB報告書のB2セルが一致している拠点のシートを探して、現在の手作業に記載されていることを実施したいです。 詳しい方がいらっしゃいましたらご回答をよろしくお願いします。

Excel・66閲覧・xmlns="http://www.w3.org/2000/svg">500

ベストアンサー

0
qgl********

2022/7/5 21:58

これで合っているでしょうか。 ※フォルダを指定してから実行します。 ※マクロファイルはB報告書にコピペしてください。 ※B報告書、A報告書は同じフォルダに入れてください。 ※A報告書があって、B報告書にシートがない場合はメッセージを表示します。 Sub sample() Dim outbook As Workbook, wb As Workbook Dim myfname As String, jobname As String Dim i As Integer, n As Integer, cnt As Integer Dim FileNum Const fld As String = "C:\○○\" 'フォルダ指定 Application.ScreenUpdating = False Set outbook = ThisWorkbook '登録番号取得 ReDim FileNum(Worksheets.Count - 4) With ActiveSheet For i = 5 To Worksheets.Count n = n + 1 FileNum(n) = Sheets(i).Cells(2, "B") Next i End With 'フォルダ処理 myfname = Dir(fld & "*.xls") If myfname <> "" Then Do While myfname <> "" If myfname <> ThisWorkbook.Name Then Workbooks.Open Filename:=fld & myfname Set wb = ActiveWorkbook '照合 With wb.Sheets(1) jobname = .Cells(2, "L") For i = 1 To UBound(FileNum) cnt = cnt + 1 If jobname = FileNum(i) Then '転記 .Range("D11:W39").Copy outbook.Worksheets(jobname).Range("D13") Application.CutCopyMode = False Exit For Else If cnt = UBound(FileNum) Then MsgBox jobname & " はシートがありません。" End If Next i cnt = 0 End With wb.Close End If myfname = Dir Loop Else MsgBox "指定フォルダにファイルがありません。" End If Application.ScreenUpdating = True End Sub

ID非公開

質問者2022/7/6 11:59

回答いただきましてありがとうございます。早速入力をしてみました。 '転記のoutbook.Worksheets(jobname).Range("D13")の箇所で、実行時エラー438 オブジェクトは、このプロパティまたはメソッドをサポートしていませんとエラーが出ております。 もし原因がわかりましたらよろしくお願いします。

ThanksImg質問者からのお礼コメント

綺麗に動作してくれました。回答ありがとうございました。

お礼日時：7/6 19:55