VBA 請求データ一覧からの複数の処理
先週 kkkkkmさんに質問をさせて頂きまして、
いろいろご指導を頂いたものです。
続編の様な形になってしまいますが、
抽出するデータの環境設定を変更致しました。
ご質問させて頂く内容は前回とほとんど変更がないのですが、
あらためて下記に記載させて頂きます。
<Worksheet1のデータ>
Ｊ列～AM列までが課税金額
「J,K,L」「M,N,O」・・・「AK,AL,AM」と3列1組（コード・費目・金額）
1組の行もあれば、複数組の行もあり。
AN列～BB列までが非課税金額
課税金額と同じく3列1組
1組の行もあれば、複数組の行もあり。
「BC」=消費税、「ＢＤ」=合計金額
※AN列の前に不規則な空白セルあり
BC列の前に不規則な空白セルあり
文章で上手く説明出来ているか自信がありませんので、
エクスポートした元データ Worksheet1と、
vbaを用いて作成した Worksheet3 をご参考に添付致します。
Worksheet1の2行目がWorksheet3の2行目に対応しています。
3行目、4行目も同様です。
不規則な空白が原因でしょうか・・・。
M列、O列は問題ないのですが、
金額が合わなかったり、N列に金額を引いてこないのです。
実行しているコードは下記になります。
Dim i As Long, j As Long, k As Long
Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet
Dim mTotal(4) As Long
Dim LastRow As Long
Dim List(4) As Variant
Set Ws1 = Sheets("Sheet1")
Set Ws2 = Sheets("Sheet2")
Set Ws3 = Sheets("請求書ひな形")
List(1) = Ws2.Range(Ws2.Cells(1, "A"), Ws2.Cells(Rows.Count, "A").End(xlUp)).Value
List(2) = Ws2.Range(Ws2.Cells(1, "B"), Ws2.Cells(Rows.Count, "B").End(xlUp)).Value
List(3) = Ws2.Range(Ws2.Cells(1, "C"), Ws2.Cells(Rows.Count, "C").End(xlUp)).Value
List(4) = Ws2.Range(Ws2.Cells(1, "D"), Ws2.Cells(Rows.Count, "D").End(xlUp)).Value
LastRow = UBound(List(1))
For i = 2 To 4
If LastRow < UBound(List(i)) Then
LastRow = UBound(List(i))
End If
Next
For i = 2 To Ws1.Cells(Rows.Count, "J").End(xlUp).Row
mTotal(1) = 0
mTotal(2) = 0
mTotal(3) = 0
mTotal(4) = 0
For j = Columns("J").Column To Columns("BB").Column Step 3
For k = 2 To LastRow
If UBound(List(1)) >= k Then
If Ws1.Cells(i, j).Value = List(1)(k, 1) Then
mTotal(1) = mTotal(1) + Ws1.Cells(i, j).Offset(0, 2).Value
Exit For
End If
End If
If UBound(List(2)) >= k Then
If Ws1.Cells(i, j).Value = List(2)(k, 1) Then
mTotal(2) = mTotal(2) + Ws1.Cells(i, j).Offset(0, 2).Value
Exit For
End If
End If
If UBound(List(3)) >= k Then
If Ws1.Cells(i, j).Value = List(3)(k, 1) Then
mTotal(3) = mTotal(3) + Ws1.Cells(i, j).Offset(0, 2).Value
Exit For
End If
End If
If UBound(List(4)) >= k Then
If Ws1.Cells(i, j).Value = List(4)(k, 1) Then
mTotal(4) = mTotal(4) + Ws1.Cells(i, j).Offset(0, 2).Value
Exit For
End If
End If
Next
Next
Ws3.Cells(i, "J").Value = mTotal(1)
Ws3.Cells(i, "K").Value = mTotal(2)
Ws3.Cells(i, "L").Value = mTotal(3)
Ws3.Cells(i, "N").Value = mTotal(4)
Ws3.Cells(i, "M").Value = Ws1.Cells(i, "BC").Value
Ws3.Cells(i, "O").Value = Ws1.Cells(i, "BD").Value
Next
Set Ws1 = Nothing
Set Ws2 = Nothing
Set Ws3 = Nothing
End Sub
本当に何度も申し訳ございません。
お時間がある時に見て頂けると有り難いです。
どうぞ宜しくお願い致します。
