【ExcelVBA】顧客別に抽出データをシート転記

質問

現在、顧客毎の支払い明細をExcelで自動発行できるものを作っています。
独学で、以下の状態までは作成できたのですが、その後、どうすれば良いのか分かりません。

[入力シート]　※以下、項目名はA6:O6に記載。
A=No.　　　　　　 F=科目名　　　　　　　K=該当期間
B=顧客ID　　　　G=業者名　　　　　　　L=本体金額
C=顧客名　　　 H=摘要【抜粋】　　　　M=消費税
D=大項目　　　　I=摘要　　　　　　　　　N=合計
E=勘定科目　　 J=説明　　　　　　　　　O=計上月

上記[入力シート]内の「C=顧客名×O=計上月」を抽出条件としたフィルタオプションで転記
というコードは、下記で成功しました。
※コード内の「顧客テーブル=入力シートの全データ」。「Q_抽出条件=顧客名×計上月」の条件
----------------------------------
Sub 必要なフィールドのみを転記()
Dim myTable As Range, myQuery As Range, taegetRnage As Range
Set myTable = Worksheets("入力Form").Range("顧客テーブル")
Set myQuery = Worksheets("入力Form").Range("Q_抽出条件")
Set targetRange = Worksheets("必要項目のみ転記").Range("b3:l3")
myTable.AdvancedFilter xlFilterCopy, myQuery, targetRange
End Sub
----------------------------------

また、顧客名毎にシート作成し、転記ということも以下コードで成功しています。
※コード内の「myList = Array("顧客A","顧客B","顧客C"・・・・・・・・・・)」は、顧客数分、名前を記載してあります。

----------------------------------
Sub 物件毎に転記()
Dim myTable As Range, mysheet As Worksheet, i As Integer
Dim myList()
myList = Array("顧客A","顧客B","顧客C"・・・・・・・・・・)
Set myTable = Worksheets("入力Form").Range("顧客テーブル")
For i = o To UBound(myList)
Set mysheet = Worksheets.Add(after:=Sheets(Sheets.Count))
mysheet.Name = myList(i) & "_支払明細"
With myTable
.AutoFilter 3, myList(i)
.Copy mysheet.Range("a2")
.AutoFilter
End With
mysheet.Range("a2").CurrentRegion.EntireColumn.AutoFit
Next
End Sub
----------------------------------

まず、顧客数分の抽出先（転記先）明細シートを用意し、必要な項目名だけを
記載しておくので、そこに「顧客名」×「計上月」の抽出条件で抽出された内容を
顧客別に指定シートに、転記したいのです。
※「顧客名」で転記先シートを予め指定できるのであれば、抽出条件は「計上月」だけで構いません。

顧客数が30件程あり、毎月、入力シートに売上データは追記されていきます。
その蓄積されていくデータの中から、一括で「(1)計上月指定　(2)顧客名別の指定シートに該当データのみを転記　(3)顧客名に該当する転記先シートがなければ、新しくシートを作成した上で転記」
という作業を行いたいと考えています。
※(3)は、Want条件なのでなくても大丈夫です。

あまりVBAの知識がない為、コードの記載方法など詳細に教えていただければ幸いです。
何卒よろしくお願い致します。

回答No.2

end-u · ベストアンサー

コード内容としては
1)Application.InputBoxで"計上月"を取得。
2)IT2セルに抽出条件の"計上月"を書き込み。
3)C列顧客名から重複を除き、ユニークな顧客リストとしてIV列に書き出し。
4)IV列の顧客リスト範囲をLoop
　Loop中に"（顧客名）_支払明細"というシートがなければ追加。
　追加時にTITLEから抽出項目名をセット。
　IU2セルに個々の顧客名をセットしAdvancedFilterで目的シートに抽出。
5)作業エリアIT:IV列を削除。
..というような流れになってます。

#本当は、TITLEの内容をコードに埋め込むのではなく、
#事前にどこかのセル範囲に抽出項目名を列挙しておいて、
#そこをコピーするようにしたほうが汎用的に使えます。

お礼

end-uさん

ご丁寧にお教えいただき、ありがとうございます！
早速、試してみます。

回答No.1

end-u

"入力Form"シートだけを別Bookにコピーし、テスト用Bookとして試してみてください。
~~~~~~~~~~~~~~~~~~~~
（"顧客テーブル"の名前定義も必要です。コピーされるとは思いますが）

【必要な事前作業】
1)現在の"顧客テーブル"の隣、P6セルに"（空白）"という項目名を追加してください。
2)名前定義"顧客テーブル"の範囲にP列まで含んでください。

コード内容は以下。

Sub try()
　　'抽出したい項目名をカンマ区切りで列挙しておきます。顧客テーブルの項目名と一致していないとダメ
　　Const TITLE = "顧客名,業者名,勘定科目,科目名,業者名,（空白）,説明,本体金額,消費税,合計,計上月"
　　Const destCell = "A2:K2" '抽出先アドレス
　　Dim ws　　　As Worksheet '抽出先Sheet
　　Dim myTable As Range　　 '顧客テーブル範囲
　　Dim r　　　 As Range　　 'Loop用
　　Dim x

　　On Error GoTo extLine
　　x = Application.InputBox("計上月？", Type:=2)
　　If VarType(x) = vbBoolean Then Exit Sub
　　Application.ScreenUpdating = False

　　With Sheets("入力Form")
　　　　Set myTable = .Range("顧客テーブル")
　　　　'検索条件範囲
　　　　.Range("IT1:IU1").Value = Array("計上月", "顧客名")
　　　　.Range("IT2").Value = x
　　　　'ユニークな顧客リストを抽出
　　　　myTable.Columns("C").AdvancedFilter Action:=xlFilterCopy, _
　　　　　　　　　　　　　　　　　　　　　　CopyToRange:=.Range("IV1"), _
　　　　　　　　　　　　　　　　　　　　　　Unique:=True
　　　　'顧客リスト範囲内セルをLoop
　　　　For Each r In .Range("IV2", .Cells(.Rows.Count, "IV").End(xlUp))
　　　　　　'wsに顧客別Sheetをセット。無い場合追加。
　　　　　　Set ws = Nothing
　　　　　　On Error Resume Next
　　　　　　Set ws = Sheets(r.Value & "_支払明細")
　　　　　　On Error GoTo extLine
　　　　　　If ws Is Nothing Then
　　　　　　　　Set ws = Sheets.Add(after:=Sheets(Sheets.Count))
　　　　　　　　ws.Name = r.Value & "_支払明細"
　　　　　　　　ws.Range(destCell).Value = Split(TITLE, ",")
　　　　　　End If
　　　　　　'検索条件として顧客名を入れ、wsに抽出。
　　　　　　.Range("IU2").Value = r.Value
　　　　　　myTable.AdvancedFilter Action:=xlFilterCopy, _
　　　　　　　　　　　　　　　　　 CriteriaRange:=.Range("IT1:IU2"), _
　　　　　　　　　　　　　　　　　 CopyToRange:=ws.Range(destCell)
　　　　Next
　　　　'作業エリアを削除
　　　　.Columns("IT:IV").Delete
　　End With

extLine:
　　Set myTable = Nothing
　　Set ws = Nothing
　　Application.ScreenUpdating = True
　　If Err.Number <> 0 Then MsgBox Err.Number & "::" & Err.Description
End Sub

TITLE = "顧客名,..の箇所で抽出項目名を列挙しておく必要があります。
"顧客テーブル"の項目名と一致させてください。
新規Sheetを追加する時に使います。

検索条件などを書き込むために、作業エリアとしてIT:IV列を使います。
IT1:IU2には検索条件。
IV列は顧客名リスト用です。