マクロで雛型ファイルを開き、情報を入力後、新しい名前で保存したい

マクロ初心者です。
以下の作業を行いたいのですが、お知恵を貸していただけないでしょうか。
マクロの一部を変更することはできても最初から作ることができません...
コピペ可能なコードを記載くださると大変嬉しいです。

【作業内容】
・Excel（元ファイル）に記載の内容を元に、１行につき１ファイルずつ申請書を作成、保存する。
・申請書（雛型）の様式は決まっており、変更できない。

【作りたいマクロ】
①元ファイル（画像イメージ）のA列に「済」が入っていない行を上から順番に処理する。
②雛型ファイルを開く
③処理する行のB列「処理日付」を、申請書（雛型）のH4セルに値貼付
④処理する行のC列「店名」を、申請書（雛型）のD10セルに値貼付
...以下全ての情報（9箇所）を値貼付
⑤ファイル名を元ファイルのJ列に指定して保存
⑥元ファイルの処理した行のＡ列に「済」を入力


申請書（雛型）の入力セルが飛び飛びになっており、いちいちコピペして名前をつけて保存するのに非常に時間がかかります(>_<)
何とかできればと挑戦してみましたが上手くいかず...
お力添え頂けたら嬉しいです。

No.1 ベストアンサー 回答者： rukaandkaito 回答日時： 2019/07/02 11:23

コード作ってみました

不明な部分はこちらで適当に設定しています
①デスクトップに申請書というフォルダがあり、その中に申請書_雛形.xlsxというファイルがある
②ファイル名は『店コード』と『氏名コード』、『処理日』の組み合わせで作成される
③ファイルの保存先は雛形と同じ
④申請書の貼り付け座標は適当ですので修正してください
--------------------------------------------------------------------------------
Public Sub Sample()
　　
　　Dim objB　　As Workbook
　　Dim intR　　As Integer
　　Dim strB　　As String
　　
　　Application.ScreenUpdating = False
　　Application.DisplayAlerts = False
　　
　　Set objB = ThisWorkbook
　　
　　intR = 4
　　Do Until objB.Sheets(1).Cells(intR, 2).Value = ""
　　　　With Workbooks.Open("C:\Users\Owner\Desktop\申請書\申請書_雛形.xlsx")
　　　　　　.Sheets(1).Range("H4").Value = objB.Sheets(1).Cells(intR, 2).Value
　　　　　　.Sheets(1).Range("D10").Value = objB.Sheets(1).Cells(intR, 3).Value
　　　　　　.Sheets(1).Range("A12").Value = objB.Sheets(1).Cells(intR, 4).Value
　　　　　　.Sheets(1).Range("H13").Value = objB.Sheets(1).Cells(intR, 5).Value
　　　　　　.Sheets(1).Range("C14").Value = objB.Sheets(1).Cells(intR, 6).Value
　　　　　　.Sheets(1).Range("D10").Value = objB.Sheets(1).Cells(intR, 7).Value
　　　　　　.Sheets(1).Range("D10").Value = objB.Sheets(1).Cells(intR, 8).Value
　　　　　　.Sheets(1).Range("D10").Value = objB.Sheets(1).Cells(intR, 9).Value
　　　　　　strB = ""
　　　　　　strB = strB & "C:\Users\Owner\Desktop\申請書\申請書"
　　　　　　strB = strB & "_" & Format(Now(), "yyyymmdd")
　　　　　　strB = strB & "_" & objB.Sheets(1).Cells(intR, 4).Value
　　　　　　strB = strB & "_" & objB.Sheets(1).Cells(intR, 6).Value & ".xlsx"
　　　　　　.SaveAs Filename:=strB
　　　　　　objB.Sheets(1).Cells(intR, 10).Value = strB
　　　　　　objB.Sheets(1).Cells(intR, 1).Value = "済"
　　　　　　.Close False
　　　　End With
　　　　intR = intR + 1
　　Loop
　　Application.ScreenUpdating = True
　　Application.DisplayAlerts = True
End Sub
--------------------------------------------------------------------------------
お試しください

この回答へのお礼

さっそく明日試してみます！
ありがとうございます！

お礼日時：2019/07/03 21:32