とても分かりやすかったです！ ありがとうございます。 1点ご相談させてください！ こちらを参考にDBのデータ欄を増やしてvbaを組んでみたのですが上手くいきませんでした。 DBの数量や品名欄に割引欄等を追加したので Dim A, B, C, E, F With Sheets("DB").Range("M1").CurrentRegion.Offset(1, 0) A = .Resize(.Rows.Count - 1).Columns(2) B = .Resize(.Rows.Count - 1).Columns(3) C = .Resize(.Rows.Count - 1).Columns(4) E = .Resize(.Rows.Count - 1).Columns(5) F = .Resize(.Rows.Count - 1).Columns(6) End With Sheets("請求書").Range("A7").Resize(UBound(A)) = A Sheets("請求書").Range("B7").Resize(UBound(B)) = B Sheets("請求書").Range("C7").Resize(UBound(C)) = C Sheets("請求書").Range("D7").Resize(UBound(E)) = E Sheets("請求書").Range("E7").Resize(UBound(F)) = F こちらの変数を追加しております。 項目が増えたため動画ではセルFで行っている計算をセルM以降や請求書の取引先等のコピー位置は対応する場所へ変更しております。 こちらを実行すると1社目のPDFは出力されるのですが2社目以降はエラーコード１３、型が一致しませんとエラーが表示されます。 経過を見てみると2社目の Sheets("請求書").Range("A7").Resize(UBound(A)) = A この部分でエラーが起きているようです。 ローカルウィンドウでみても2社目の変数に数値は読み込まれており、変数にデータ型の設定を行っても変わりはありませんでした。 vbaを勉強中で初歩的な質問かと思いますがご教授頂けますと幸いです！ よろしくお願いします。 【全文】 Sub bbb() Sheets("DB").Range("A1").CurrentRegion.Columns(1).Copy Sheets("DB").Range("M1") Sheets("DB").Range("M1").CurrentRegion.RemoveDuplicates 1, xlYes Dim D With Sheets("DB").Range("M1").CurrentRegion.Offset(1, 0) D = .Resize(.Rows.Count - 1) End With Sheets("DB").Range("M1").CurrentRegion.ClearContents For i = 1 To UBound(D, 1) Sheets("DB").Range("A1").AutoFilter 1, D(i, 1) Sheets("DB").Range("A1").CurrentRegion.Copy Sheets("DB").Range("M1") Sheets("DB").Range("A1").AutoFilter Sheets("請求書").Range("A3") = Sheets("DB").Range("M2") Dim A, B, C, E, F With Sheets("DB").Range("M1").CurrentRegion.Offset(1, 0) A = .Resize(.Rows.Count - 1).Columns(2) B = .Resize(.Rows.Count - 1).Columns(3) C = .Resize(.Rows.Count - 1).Columns(4) E = .Resize(.Rows.Count - 1).Columns(5) F = .Resize(.Rows.Count - 1).Columns(6) End With Sheets("請求書").Range("A7").Resize(UBound(A)) = A Sheets("請求書").Range("B7").Resize(UBound(B)) = B Sheets("請求書").Range("C7").Resize(UBound(C)) = C Sheets("請求書").Range("D7").Resize(UBound(E)) = E Sheets("請求書").Range("E7").Resize(UBound(F)) = F Sheets("DB").Range("M1").CurrentRegion.ClearContents With Sheets("請求書") .ExportAsFixedFormat 0, ThisWorkbook.Path & "\" & .Range("A3") & ".pdf" End With Next End Sub
Dim A, B, C, E, F With Sheets("DB").Range("M1").CurrentRegion.Offset(1, 0) A = .Resize(.Rows.Count - 1).Columns(2) B = .Resize(.Rows.Count - 1).Columns(3) C = .Resize(.Rows.Count - 1).Columns(4) E = .Resize(.Rows.Count - 1).Columns(5) F = .Resize(.Rows.Count - 1).Columns(6) End With
'項目が2つ以上となり、変数が配列になる場合 If IsArray(A) Then Sheets("請求書").Range("A7").Resize(UBound(A)) = A Sheets("請求書").Range("B7").Resize(UBound(B)) = B Sheets("請求書").Range("C7").Resize(UBound(C)) = C Sheets("請求書").Range("D7").Resize(UBound(E)) = E Sheets("請求書").Range("E7").Resize(UBound(F)) = F '項目が1つとなり、変数が配列ではない場合 Else Sheets("請求書").Range("A7") = A Sheets("請求書").Range("B7") = B Sheets("請求書").Range("C7") = C Sheets("請求書").Range("D7") = E Sheets("請求書").Range("E7") = F End If
With Sheets("請求書") .ExportAsFixedFormat 0, ThisWorkbook.Path & "\" & .Range("A3") & ".pdf" End With
Next End Sub エラーの原因としては、配列ではない変数に「Ubound」を使用したのが原因となります。 変数が「配列」の場合のみに、「UBound」を使うことができます。 今回の場合だと、取引先ごと品目などの項目数が2つ以上の場合には、変数は「配列」になります。 項目が「1つ」の場合は「配列ではない変数」になります。 なのでエラー回避策としては、 変数が配列の場合は「Uboundを使って」、変数が配列ではない場合は「UBoundを使わない」というように条件分岐します。 追加したVBAコードとしては、セルに入力する変数が「配列」もしくは「配列ではない」場合で、条件分岐して入力しています。 セルに入力する値が「配列」の場合で、項目が複数ある場合は、次のように入力します。 Sheets("請求書").Range("A7").Resize(UBound(A)) = A また、セルに入力する値が「配列ではない」場合は、項目が1つのみなので、次のように入力をします。 Sheets("請求書").Range("A7") = A 上記のように修正をすると、エラーを回避することができるかと思います。 あと、最初の方に、「請求書」シートを初期化するVBAコードを追記しております。 貼り付けする項目数が変わる場合は、前のデータが残ってしまう場合がありますので、最初にシートを初期化しておくといいかと思います。 参考になればと思います（^^）
すみません。。。 こちらの改良で困ったことがあります💦 Sub 新案件管理シート() Sheets("DB").Range("A1").CurrentRegion.Columns(1).Copy Sheets("DB").Range("Z1") Sheets("DB").Range("Z1").CurrentRegion.RemoveDuplicates 1, xlYes Dim D With Sheets("DB").Range("Z1").CurrentRegion.Offset(1, 0) D = .Resize(.Rows.Count - 1) End With '請求書シートを初期化 Sheets("DB").Range("Z1").CurrentRegion.ClearContents For i = 1 To UBound(D, 1) Sheets("DB").Range("A1").AutoFilter 1, D(i, 1) Sheets("DB").Range("A1").CurrentRegion.Copy Sheets("DB").Range("Z1") Sheets("DB").Range("A1").AutoFilter Sheets("請求書").Range("A2,A6:G54").ClearContents Sheets("請求書").Range("A2") = Sheets("DB").Range("AA2") Dim A, B, C, E, F, G, H With Sheets("DB").Range("Z1").CurrentRegion.Offset(1, 0) A = .Resize(.Rows.Count - 1).Columns(1) B = .Resize(.Rows.Count - 1).Columns(6) C = .Resize(.Rows.Count - 1).Columns(7) E = .Resize(.Rows.Count - 1).Columns(8) F = .Resize(.Rows.Count - 1).Columns(9) G = .Resize(.Rows.Count - 1).Columns(10) H = .Resize(.Rows.Count - 1).Columns(11) End With '項目が2つ以上となり、変数が配列になる場合 If IsArray(A) Then Sheets("請求書").Range("A6").Resize(UBound(A)) = A Sheets("請求書").Range("B6").Resize(UBound(B)) = B Sheets("請求書").Range("C6").Resize(UBound(C)) = C Sheets("請求書").Range("D6").Resize(UBound(E)) = E Sheets("請求書").Range("E6").Resize(UBound(F)) = F Sheets("請求書").Range("F6").Resize(UBound(F)) = G Sheets("請求書").Range("G6").Resize(UBound(F)) = H '項目が1つとなり、変数が配列ではない場合 Else Sheets("請求書").Range("A6") = A Sheets("請求書").Range("B6") = B Sheets("請求書").Range("C6") = C Sheets("請求書").Range("D6") = E Sheets("請求書").Range("E6") = F Sheets("請求書").Range("F6") = G Sheets("請求書").Range("G6") = H End If Sheets("DB").Range("Z1").CurrentRegion.ClearContents With Sheets("請求書") .ExportAsFixedFormat 0, ThisWorkbook.Path & "\" & .Range("A2") & ".pdf" End With Next End Sub このvbaですが下記の定義Ａの部分でエラー1004が出てしまいます。 ご教授頂けますと幸いです。
エラー部分 Dim A, B, C, E, F, G, H With Sheets("DB").Range("Z1").CurrentRegion.Offset(1, 0) A = .Resize(.Rows.Count - 1).Columns(1) B = .Resize(.Rows.Count - 1).Columns(6) C = .Resize(.Rows.Count - 1).Columns(7) E = .Resize(.Rows.Count - 1).Columns(8) F = .Resize(.Rows.Count - 1).Columns(9) G = .Resize(.Rows.Count - 1).Columns(10) H = .Resize(.Rows.Count - 1).Columns(11) End With
'品目以下を転記 With Sheets("DB").Range("F1").CurrentRegion.Offset(1, 0) A = .Resize(.Rows.Count - 1).Columns(2) B = .Resize(.Rows.Count - 1).Columns(3) C = .Resize(.Rows.Count - 1).Columns(4) E = .Rows.Count - 1 End With
Sheets("請求書").Range("A10").Resize(E) = A Sheets("請求書").Range("D10").Resize(E) = B Sheets("請求書").Range("E10").Resize(E) = C
'PDFで保存 With Sheets("請求書") .ExportAsFixedFormat 0, ThisWorkbook.Path & "\" & .Range("A2") & "_" & .Range("A10") & ".pdf" End With
'品目以下を転記 With Sheets("DB").Range("F1").CurrentRegion.Offset(1, 0) A = .Resize(.Rows.Count - 1).Columns(2) B = .Resize(.Rows.Count - 1).Columns(3) C = .Resize(.Rows.Count - 1).Columns(4) E = .Rows.Count - 1 End With
Sheets("請求書").Range("A10").Resize(E) = A Sheets("請求書").Range("D10").Resize(E) = B Sheets("請求書").Range("E10").Resize(E) = C
'PDFで保存 With Sheets("請求書") .ExportAsFixedFormat 0, ThisWorkbook.Path & "\" & .Range("A2") & "_" & .Range("A10") & ".pdf" End With
コメントありがとうございます！ 日付を取得したい場合は「Now」を使うとできます。 または、取得した日付のフォーマットを指定したい場合は、「Format」を使うといいです。 次のようなVBAコードになります。 ↓日付と時間を文字数を固定して取得 Dim H H = Format(Now, "yyyymmdd-hhmmss") ↓全体のVBAコードは、次のようになります。 Sub TEST2()
Dim A, B, C With Sheets("DB").Range("F1").CurrentRegion.Offset(1, 0) A = .Resize(.Rows.Count - 1).Columns(2) B = .Resize(.Rows.Count - 1).Columns(3) C = .Resize(.Rows.Count - 1).Columns(4) End With
Sheets("請求書").Range("A10").Resize(UBound(A)) = A Sheets("請求書").Range("D10").Resize(UBound(B)) = B Sheets("請求書").Range("E10").Resize(UBound(C)) = C
コメントありがとうございます！ 転記する際に「UBound」を使ってしまいますと、1行だった場合にエラーが出ておりました。 With Sheets("DB").Range("F1").CurrentRegion.Offset(1, 0) A = .Resize(.Rows.Count - 1).Columns(2) '品目 B = .Resize(.Rows.Count - 1).Columns(3) '単価 C = .Resize(.Rows.Count - 1).Columns(4) '数量 End With
Sheets("請求書").Range("A10").Resize(UBound(A, 1)) = A '品目 Sheets("請求書").Range("D10").Resize(UBound(B, 1)) = B '単価 Sheets("請求書").Range("E10").Resize(UBound(C, 1)) = C '数量 下記のように、「.Rows.Count - 1」を使って、見出しを除いたデータの行数を、そのまま使用することで、1行の場合でもエラーなく転記することができます。 With Sheets("DB").Range("F1").CurrentRegion.Offset(1, 0) A = .Resize(.Rows.Count - 1).Columns(2) '品目 B = .Resize(.Rows.Count - 1).Columns(3) '単価 C = .Resize(.Rows.Count - 1).Columns(4) '数量 Sheets("請求書").Range("A10").Resize(.Rows.Count - 1) = A '品目 Sheets("請求書").Range("D10").Resize(.Rows.Count - 1) = B '単価 Sheets("請求書").Range("E10").Resize(.Rows.Count - 1) = C '数量 End With だいぶ遅くなり恐れ入ります。 備忘のためコメントいたします。
初心者ですがとてもわかりやすい大変参考になりました。これで、時間がかかっていた作業がものすごく短縮されそうです。
ありがとうございます。
大変参考になりました驚きの連続でした
とても分かりやすかったです！
ありがとうございます。
1点ご相談させてください！
こちらを参考にDBのデータ欄を増やしてvbaを組んでみたのですが上手くいきませんでした。
DBの数量や品名欄に割引欄等を追加したので
Dim A, B, C, E, F
With Sheets("DB").Range("M1").CurrentRegion.Offset(1, 0)
A = .Resize(.Rows.Count - 1).Columns(2)
B = .Resize(.Rows.Count - 1).Columns(3)
C = .Resize(.Rows.Count - 1).Columns(4)
E = .Resize(.Rows.Count - 1).Columns(5)
F = .Resize(.Rows.Count - 1).Columns(6)
End With
Sheets("請求書").Range("A7").Resize(UBound(A)) = A
Sheets("請求書").Range("B7").Resize(UBound(B)) = B
Sheets("請求書").Range("C7").Resize(UBound(C)) = C
Sheets("請求書").Range("D7").Resize(UBound(E)) = E
Sheets("請求書").Range("E7").Resize(UBound(F)) = F
こちらの変数を追加しております。
項目が増えたため動画ではセルFで行っている計算をセルM以降や請求書の取引先等のコピー位置は対応する場所へ変更しております。
こちらを実行すると1社目のPDFは出力されるのですが2社目以降はエラーコード１３、型が一致しませんとエラーが表示されます。
経過を見てみると2社目の
Sheets("請求書").Range("A7").Resize(UBound(A)) = A
この部分でエラーが起きているようです。
ローカルウィンドウでみても2社目の変数に数値は読み込まれており、変数にデータ型の設定を行っても変わりはありませんでした。
vbaを勉強中で初歩的な質問かと思いますがご教授頂けますと幸いです！
よろしくお願いします。
【全文】
Sub bbb()
Sheets("DB").Range("A1").CurrentRegion.Columns(1).Copy Sheets("DB").Range("M1")
Sheets("DB").Range("M1").CurrentRegion.RemoveDuplicates 1, xlYes
Dim D
With Sheets("DB").Range("M1").CurrentRegion.Offset(1, 0)
D = .Resize(.Rows.Count - 1)
End With
Sheets("DB").Range("M1").CurrentRegion.ClearContents
For i = 1 To UBound(D, 1)
Sheets("DB").Range("A1").AutoFilter 1, D(i, 1)
Sheets("DB").Range("A1").CurrentRegion.Copy Sheets("DB").Range("M1")
Sheets("DB").Range("A1").AutoFilter
Sheets("請求書").Range("A3") = Sheets("DB").Range("M2")
Dim A, B, C, E, F
With Sheets("DB").Range("M1").CurrentRegion.Offset(1, 0)
A = .Resize(.Rows.Count - 1).Columns(2)
B = .Resize(.Rows.Count - 1).Columns(3)
C = .Resize(.Rows.Count - 1).Columns(4)
E = .Resize(.Rows.Count - 1).Columns(5)
F = .Resize(.Rows.Count - 1).Columns(6)
End With
Sheets("請求書").Range("A7").Resize(UBound(A)) = A
Sheets("請求書").Range("B7").Resize(UBound(B)) = B
Sheets("請求書").Range("C7").Resize(UBound(C)) = C
Sheets("請求書").Range("D7").Resize(UBound(E)) = E
Sheets("請求書").Range("E7").Resize(UBound(F)) = F
Sheets("DB").Range("M1").CurrentRegion.ClearContents
With Sheets("請求書")
.ExportAsFixedFormat 0, ThisWorkbook.Path & "\" & .Range("A3") & ".pdf"
End With
Next
End Sub
コメントありがとうございます！
ご紹介したVBAコードでは、取引先の項目数が「1つ」の場合は、エラーとなってしまいます（^^;）大変失礼しました。次のようにセルに入力すると、エラーを回避できるかと思います。
Sub bbb()
Sheets("DB").Range("A1").CurrentRegion.Columns(1).Copy Sheets("DB").Range("M1")
Sheets("DB").Range("M1").CurrentRegion.RemoveDuplicates 1, xlYes
Dim D
With Sheets("DB").Range("M1").CurrentRegion.Offset(1, 0)
D = .Resize(.Rows.Count - 1)
End With
'請求書シートを初期化
Sheets("DB").Range("M1").CurrentRegion.ClearContents
For i = 1 To UBound(D, 1)
Sheets("DB").Range("A1").AutoFilter 1, D(i, 1)
Sheets("DB").Range("A1").CurrentRegion.Copy Sheets("DB").Range("M1")
Sheets("DB").Range("A1").AutoFilter
Sheets("請求書").Range("A3,A7:E9").ClearContents
Sheets("請求書").Range("A3") = Sheets("DB").Range("M2")
Dim A, B, C, E, F
With Sheets("DB").Range("M1").CurrentRegion.Offset(1, 0)
A = .Resize(.Rows.Count - 1).Columns(2)
B = .Resize(.Rows.Count - 1).Columns(3)
C = .Resize(.Rows.Count - 1).Columns(4)
E = .Resize(.Rows.Count - 1).Columns(5)
F = .Resize(.Rows.Count - 1).Columns(6)
End With
'項目が2つ以上となり、変数が配列になる場合
If IsArray(A) Then
Sheets("請求書").Range("A7").Resize(UBound(A)) = A
Sheets("請求書").Range("B7").Resize(UBound(B)) = B
Sheets("請求書").Range("C7").Resize(UBound(C)) = C
Sheets("請求書").Range("D7").Resize(UBound(E)) = E
Sheets("請求書").Range("E7").Resize(UBound(F)) = F
'項目が1つとなり、変数が配列ではない場合
Else
Sheets("請求書").Range("A7") = A
Sheets("請求書").Range("B7") = B
Sheets("請求書").Range("C7") = C
Sheets("請求書").Range("D7") = E
Sheets("請求書").Range("E7") = F
End If
Sheets("DB").Range("M1").CurrentRegion.ClearContents
With Sheets("請求書")
.ExportAsFixedFormat 0, ThisWorkbook.Path & "\" & .Range("A3") & ".pdf"
End With
Next
End Sub
エラーの原因としては、配列ではない変数に「Ubound」を使用したのが原因となります。
変数が「配列」の場合のみに、「UBound」を使うことができます。
今回の場合だと、取引先ごと品目などの項目数が2つ以上の場合には、変数は「配列」になります。
項目が「1つ」の場合は「配列ではない変数」になります。
なのでエラー回避策としては、
変数が配列の場合は「Uboundを使って」、変数が配列ではない場合は「UBoundを使わない」というように条件分岐します。
追加したVBAコードとしては、セルに入力する変数が「配列」もしくは「配列ではない」場合で、条件分岐して入力しています。
セルに入力する値が「配列」の場合で、項目が複数ある場合は、次のように入力します。
Sheets("請求書").Range("A7").Resize(UBound(A)) = A
また、セルに入力する値が「配列ではない」場合は、項目が1つのみなので、次のように入力をします。
Sheets("請求書").Range("A7") = A
上記のように修正をすると、エラーを回避することができるかと思います。
あと、最初の方に、「請求書」シートを初期化するVBAコードを追記しております。
貼り付けする項目数が変わる場合は、前のデータが残ってしまう場合がありますので、最初にシートを初期化しておくといいかと思います。
参考になればと思います（^^）
ご返信ありがとうございます！
やりたかったことが出来ました。
あとでゆっくり実行しながら流れを見たいと思います！
配列とか使える使えない関数とかvbaって難しいですね。。。
遅くなりましたが動画いつも拝見させていただいております！
これからも勉強させていただきますのでよろしくお願いします！
すみません。。。
こちらの改良で困ったことがあります💦
Sub 新案件管理シート()
Sheets("DB").Range("A1").CurrentRegion.Columns(1).Copy Sheets("DB").Range("Z1")
Sheets("DB").Range("Z1").CurrentRegion.RemoveDuplicates 1, xlYes
Dim D
With Sheets("DB").Range("Z1").CurrentRegion.Offset(1, 0)
D = .Resize(.Rows.Count - 1)
End With
'請求書シートを初期化
Sheets("DB").Range("Z1").CurrentRegion.ClearContents
For i = 1 To UBound(D, 1)
Sheets("DB").Range("A1").AutoFilter 1, D(i, 1)
Sheets("DB").Range("A1").CurrentRegion.Copy Sheets("DB").Range("Z1")
Sheets("DB").Range("A1").AutoFilter
Sheets("請求書").Range("A2,A6:G54").ClearContents
Sheets("請求書").Range("A2") = Sheets("DB").Range("AA2")
Dim A, B, C, E, F, G, H
With Sheets("DB").Range("Z1").CurrentRegion.Offset(1, 0)
A = .Resize(.Rows.Count - 1).Columns(1)
B = .Resize(.Rows.Count - 1).Columns(6)
C = .Resize(.Rows.Count - 1).Columns(7)
E = .Resize(.Rows.Count - 1).Columns(8)
F = .Resize(.Rows.Count - 1).Columns(9)
G = .Resize(.Rows.Count - 1).Columns(10)
H = .Resize(.Rows.Count - 1).Columns(11)
End With
'項目が2つ以上となり、変数が配列になる場合
If IsArray(A) Then
Sheets("請求書").Range("A6").Resize(UBound(A)) = A
Sheets("請求書").Range("B6").Resize(UBound(B)) = B
Sheets("請求書").Range("C6").Resize(UBound(C)) = C
Sheets("請求書").Range("D6").Resize(UBound(E)) = E
Sheets("請求書").Range("E6").Resize(UBound(F)) = F
Sheets("請求書").Range("F6").Resize(UBound(F)) = G
Sheets("請求書").Range("G6").Resize(UBound(F)) = H
'項目が1つとなり、変数が配列ではない場合
Else
Sheets("請求書").Range("A6") = A
Sheets("請求書").Range("B6") = B
Sheets("請求書").Range("C6") = C
Sheets("請求書").Range("D6") = E
Sheets("請求書").Range("E6") = F
Sheets("請求書").Range("F6") = G
Sheets("請求書").Range("G6") = H
End If
Sheets("DB").Range("Z1").CurrentRegion.ClearContents
With Sheets("請求書")
.ExportAsFixedFormat 0, ThisWorkbook.Path & "\" & .Range("A2") & ".pdf"
End With
Next
End Sub
このvbaですが下記の定義Ａの部分でエラー1004が出てしまいます。
ご教授頂けますと幸いです。
エラー部分
Dim A, B, C, E, F, G, H
With Sheets("DB").Range("Z1").CurrentRegion.Offset(1, 0)
A = .Resize(.Rows.Count - 1).Columns(1)
B = .Resize(.Rows.Count - 1).Columns(6)
C = .Resize(.Rows.Count - 1).Columns(7)
E = .Resize(.Rows.Count - 1).Columns(8)
F = .Resize(.Rows.Count - 1).Columns(9)
G = .Resize(.Rows.Count - 1).Columns(10)
H = .Resize(.Rows.Count - 1).Columns(11)
End With
取引先別でなおかつ品名別で請求書を作りたいですが難しいでしょうか？
コメントありがとうございます！
取引先別で、品目別で作成したい場合は、取引先リストと品目リストを作成することでできます。
VBAコードは次のようになります。
Sub TEST1()
'取引先リスト取得
Sheets("DB").Range("A1").CurrentRegion.Columns(1).Copy Sheets("DB").Range("F1")
Sheets("DB").Range("F1").CurrentRegion.RemoveDuplicates 1, xlYes
Dim List1, List2
With Sheets("DB").Range("F1").CurrentRegion.Offset(1, 0)
List1 = .Resize(.Rows.Count - 1)
End With
Sheets("DB").Range("F1").CurrentRegion.ClearContents
'品目リスト取得
Sheets("DB").Range("A1").CurrentRegion.Columns(2).Copy Sheets("DB").Range("F1")
Sheets("DB").Range("F1").CurrentRegion.RemoveDuplicates 1, xlYes
With Sheets("DB").Range("F1").CurrentRegion.Offset(1, 0)
List2 = .Resize(.Rows.Count - 1)
End With
Sheets("DB").Range("F1").CurrentRegion.ClearContents
For i = 1 To UBound(List1, 1)
For j = 1 To UBound(List2, 1)
'請求書クリア
Sheets("請求書").Range("A2,A10:E12").ClearContents
'取引先ごとで品目ごとに抽出
Sheets("DB").Range("A1").AutoFilter 1, List1(i, 1) '取引先でフィルタ
Sheets("DB").Range("A1").AutoFilter 2, List2(j, 1) '品目でフィルタ
Sheets("DB").Range("A1").CurrentRegion.Copy Sheets("DB").Range("F1")
Sheets("DB").Range("A1").AutoFilter
Dim A, B, C, E
'抽出データがある場合
If WorksheetFunction.Subtotal(103, Range("F1").EntireColumn) > 1 Then
'取引先を転記
Sheets("請求書").Range("A2") = Sheets("DB").Range("F2")
'品目以下を転記
With Sheets("DB").Range("F1").CurrentRegion.Offset(1, 0)
A = .Resize(.Rows.Count - 1).Columns(2)
B = .Resize(.Rows.Count - 1).Columns(3)
C = .Resize(.Rows.Count - 1).Columns(4)
E = .Rows.Count - 1
End With
Sheets("請求書").Range("A10").Resize(E) = A
Sheets("請求書").Range("D10").Resize(E) = B
Sheets("請求書").Range("E10").Resize(E) = C
'PDFで保存
With Sheets("請求書")
.ExportAsFixedFormat 0, ThisWorkbook.Path & "\" & .Range("A2") & "_" & .Range("A10") & ".pdf"
End With
End If
'抽出データをクリア
Sheets("DB").Range("F1").CurrentRegion.ClearContents
Next
Next
End Sub
手順としては、次のようになります。
・取引先リストを作成（AAA～CCC）
・品目リストを作成（デスクトップPC、ノートパソコン、マウス）
・取引先と品目リストでそれぞれループ
・請求書シートのデータをクリア
・取引先と品目ごとにデータを抽出
・取引先と品目以下を請求書シートに転記
・PDFを作成
・抽出データをクリア
「取引先と品目リストを作成する」ところと、「取引先と品目ごとにデータを抽出する」ところがポイントとなります。
実行すると、
AAA_デスクトップPC.pdf
AAA_ノートパソコン.pdf
AAA_マウス.pdf
BBB_デスクトップPC.pdf
BBB_ノートパソコン.pdf
BBB_マウス.pdf
CCC_デスクトップPC.pdf
CCC_ノートパソコン.pdf
CCC_マウス.pdf
というように、同フォルダに上記のファイルが作成されます。
参考になればと思います（^^）
一部VBAコードに訂正がありました。正しくは下記となります。
Subtotal関数の引数内で、シートを指定しておりませんでしたので、シートを指定しております。
Sub TEST1()
'取引先リスト取得
Sheets("DB").Range("A1").CurrentRegion.Columns(1).Copy Sheets("DB").Range("F1")
Sheets("DB").Range("F1").CurrentRegion.RemoveDuplicates 1, xlYes
Dim List1, List2
With Sheets("DB").Range("F1").CurrentRegion.Offset(1, 0)
List1 = .Resize(.Rows.Count - 1)
End With
Sheets("DB").Range("F1").CurrentRegion.ClearContents
'品目リスト取得
Sheets("DB").Range("A1").CurrentRegion.Columns(2).Copy Sheets("DB").Range("F1")
Sheets("DB").Range("F1").CurrentRegion.RemoveDuplicates 1, xlYes
With Sheets("DB").Range("F1").CurrentRegion.Offset(1, 0)
List2 = .Resize(.Rows.Count - 1)
End With
Sheets("DB").Range("F1").CurrentRegion.ClearContents
For i = 1 To UBound(List1, 1)
For j = 1 To UBound(List2, 1)
'請求書クリア
Sheets("請求書").Range("A2,A10:E12").ClearContents
'取引先ごとで品目ごとに抽出
Sheets("DB").Range("A1").AutoFilter 1, List1(i, 1) '取引先でフィルタ
Sheets("DB").Range("A1").AutoFilter 2, List2(j, 1) '品目でフィルタ
Sheets("DB").Range("A1").CurrentRegion.Copy Sheets("DB").Range("F1")
Sheets("DB").Range("A1").AutoFilter
Dim A, B, C, E
'抽出データがある場合
If WorksheetFunction.Subtotal(103, Sheets("DB").Range("F1").EntireColumn) > 1 Then
'取引先を転記
Sheets("請求書").Range("A2") = Sheets("DB").Range("F2")
'品目以下を転記
With Sheets("DB").Range("F1").CurrentRegion.Offset(1, 0)
A = .Resize(.Rows.Count - 1).Columns(2)
B = .Resize(.Rows.Count - 1).Columns(3)
C = .Resize(.Rows.Count - 1).Columns(4)
E = .Rows.Count - 1
End With
Sheets("請求書").Range("A10").Resize(E) = A
Sheets("請求書").Range("D10").Resize(E) = B
Sheets("請求書").Range("E10").Resize(E) = C
'PDFで保存
With Sheets("請求書")
.ExportAsFixedFormat 0, ThisWorkbook.Path & "\" & .Range("A2") & "_" & .Range("A10") & ".pdf"
End With
End If
'抽出データをクリア
Sheets("DB").Range("F1").CurrentRegion.ClearContents
Next
Next
End Sub
すごくわかりやすく、早速作成しております。
PDFで複数の請求書を作成するのを
ボタンで操作したいのですが
ボタンの作成方法を教えていただけますか？
コメントありがとうございます！
下記の手順で、PDFで複数請求書を作成するVBAコードを、ボタンから実行することができます。
■手順
「開発」タブ→「挿入」→「フォームコントロール」から「ボタン」を選択します。
ボタンの大きさをドラッグして指定して挿入します。
ボタンを挿入すると、マクロの登録画面が表示されます。
登録したいマクロを選択して、OKをクリックします。
VBAコードをボタンに登録することができます。
下記のブログにて、指定したVBAコードを、ボタンに登録する方法について解説していますので、参考になるかと思います。
↓VBAコードをボタンに登録する方法
daitaideit.com/vba-make-run-button/
参考になればと思います（^^）
返信ありがとうございます😭
早速、できました！
しかし、
エラー13が出てしまいました。
会社名を増やしました。
よろしければ教えていただけますでしょうか？
大変面白かったです。勉強になりました。
一つ質問させてください。
PDFファイルに日付表示をさせたい場合はどのようにコードを書いたらよいのでしょうか?
Formatを使用するのは予想がつくのですが特定の参照元のセルの日付をPDFに表示させたいです。
なのでforamt(rangeとなると思うのですがご教授お願いいたします。
コメントありがとうございます！
日付を取得したい場合は「Now」を使うとできます。
または、取得した日付のフォーマットを指定したい場合は、「Format」を使うといいです。
次のようなVBAコードになります。
↓日付と時間を文字数を固定して取得
Dim H
H = Format(Now, "yyyymmdd-hhmmss")
↓全体のVBAコードは、次のようになります。
Sub TEST2()
Sheets("DB").Range("A1").CurrentRegion.Columns(1).Copy Sheets("DB").Range("F1")
Sheets("DB").Range("F1").CurrentRegion.RemoveDuplicates 1, xlYes
Dim D
With Sheets("DB").Range("F1").CurrentRegion.Offset(1, 0)
D = .Resize(.Rows.Count - 1)
End With
Sheets("DB").Range("F1").CurrentRegion.ClearContents
For i = 1 To UBound(D, 1)
Sheets("DB").Range("A1").AutoFilter 1, D(i, 1)
Sheets("DB").Range("A1").CurrentRegion.Copy Sheets("DB").Range("F1")
Sheets("DB").Range("A1").AutoFilter
Sheets("請求書").Range("A2") = Sheets("DB").Range("F2")
Dim A, B, C
With Sheets("DB").Range("F1").CurrentRegion.Offset(1, 0)
A = .Resize(.Rows.Count - 1).Columns(2)
B = .Resize(.Rows.Count - 1).Columns(3)
C = .Resize(.Rows.Count - 1).Columns(4)
End With
Sheets("請求書").Range("A10").Resize(UBound(A)) = A
Sheets("請求書").Range("D10").Resize(UBound(B)) = B
Sheets("請求書").Range("E10").Resize(UBound(C)) = C
Sheets("DB").Range("F1").CurrentRegion.ClearContents
Dim H
H = Format(Now, "yyyymmdd-hhmmss")
With Sheets("請求書")
.ExportAsFixedFormat 0, ThisWorkbook.Path & "\" & .Range("A2") & "_" & H & ".pdf"
End With
Next
End Sub
PDFのファイル名に日付を追加するという感じです。
参考になればと思います（^^）
エクセルデータで任意のフォルダに保存したいのですがうまくいきません。何故かデスクトップに保存されてしまいます。何か良い方法はないでしょうか？
コメントありがとうございます！
任意のフォルダに保存したい場合は、
最後の方のVBAコードを変更することで、うまくいくかと思います。
・ブックを名前を付けて保存するVBAコード
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Range("A2") & ".xlsx"
↓任意のフォルダパスに変更
ActiveWorkbook.SaveAs "任意のフォルダパス" & "\" & Range("A2") & ".xlsx"
上記の変更で作成できない場合は、下記の点を確認するとうまくいくかと思います。
・注意点
任意のフォルダは、あらかじめ作成されている必要があります。
フォルダパスが誤っている場合は、デスクトップに保存される場合があります。
分かりやすい回答ありがとうございます！任意のフォルダパスを打ち込む際、区切り？の部分は¥ではダメですか?
@@yuyakoki-wb2wu
UA-camのコメントの仕様で、「/」になってしまっていますが、ご指摘のとおり、区切りは「¥」で区切るのが正しいです。
請求内容が1行の場合だと、エラーになりませんか？
コメントありがとうございます！
転記する際に「UBound」を使ってしまいますと、1行だった場合にエラーが出ておりました。
With Sheets("DB").Range("F1").CurrentRegion.Offset(1, 0)
A = .Resize(.Rows.Count - 1).Columns(2) '品目
B = .Resize(.Rows.Count - 1).Columns(3) '単価
C = .Resize(.Rows.Count - 1).Columns(4) '数量
End With
Sheets("請求書").Range("A10").Resize(UBound(A, 1)) = A '品目
Sheets("請求書").Range("D10").Resize(UBound(B, 1)) = B '単価
Sheets("請求書").Range("E10").Resize(UBound(C, 1)) = C '数量
下記のように、「.Rows.Count - 1」を使って、見出しを除いたデータの行数を、そのまま使用することで、1行の場合でもエラーなく転記することができます。
With Sheets("DB").Range("F1").CurrentRegion.Offset(1, 0)
A = .Resize(.Rows.Count - 1).Columns(2) '品目
B = .Resize(.Rows.Count - 1).Columns(3) '単価
C = .Resize(.Rows.Count - 1).Columns(4) '数量
Sheets("請求書").Range("A10").Resize(.Rows.Count - 1) = A '品目
Sheets("請求書").Range("D10").Resize(.Rows.Count - 1) = B '単価
Sheets("請求書").Range("E10").Resize(.Rows.Count - 1) = C '数量
End With
だいぶ遅くなり恐れ入ります。
備忘のためコメントいたします。