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

本当に何度も申し訳ございません。
お時間がある時に見て頂けると有り難いです。
どうぞ宜しくお願い致します。

回答No.4

kkkkkm · ベストアンサー

ふと思ったのですが、
リストは
1行目に項目(List1など)があって2行目からリストそのもの(I01など)がある前提(前回の回答No.5で示したこちらのリストの状態)でなのですが、もし1行目からリストそのもの(I01など)があるのでしたら
For k = 2 To LastRow
は
For k = 1 To LastRow
に変更してください。

以下は上記変更していないコードでの説明です。

あと、コードのセルが未入力の時にリストを見に行かないように(見に行く必要がないので)

For k = 2 To LastRow
If UBound(List(1)) >= k Then

のところを

For k = 2 To LastRow
If Ws1.Cells(i, j).Value = "" Then
Exit For
End If
If UBound(List(1)) >= k Then

に変更してください。

No.1のコードを適用している場合(JからAMまでとANからBBまで分けている場合)
後半のList(3)の上にも

For k = 2 To LastRow
If Ws1.Cells(i, j).Value = "" Then
Exit For
End If
If UBound(List(3)) >= k Then

に変更してください。

以前はデータ行に未入力があれば次の行に移るために
If Ws1.Cells(i, j).Value = "" Then
Exit For
End If
がありましたが、今回は対象行は次に移ることはありません。

ただ、これは
「リストの途中に空白セルがあり、データ行のコードのセルが空白である組の金額に値が入っている場合」がなければ計算結果は変更前と変わらないと思います。

お礼

こちらの回答でご教示頂いた修正箇所を反映させたコードで実行しましたころ、
無事 Worksheet3に請求書を作成することが出来ました。
本当に有り難うございます。何と御礼を申し上げて良いか・・・。
私の説明不足の質問にも親切にご対応頂き、
厚く御礼申し上げます。

回答No.3

kkkkkm

本題ではありませんが、環境によってはrとγよりYとγのほうが似てました。

回答No.2

kkkkkm

あと、同じコードが他のリストに存在するということはないですよね。

回答No.1

kkkkkm

画像がぼやけていてよくわかりませんが、課税非課税が前回混在していたのが分かれたという事でしょうか。

前回も半角全角前後の空白にふれたのですが

各
If UBound(List(リストの番号)) >= k Then
の下にある
If Ws1.Cells(i, j).Value = List(1)(k, 1) Then

の部分を以下に変更してみてください。

If Trim(StrConv(Ws1.Cells(i, j).Value, vbNarrow)) = Trim(StrConv(List(1)(k, 1), vbNarrow)) Then

List(1)はそれぞれの番号にしてください。

あと、「r」と「γ」のように環境によっては見た目で判別しにくい文字(rとγよりかなり見分けのつかないものもあるようです)もありますので、集計されないコードをSheet1からリストにコピペしてみて試してみてはいかがでしょう。

実行後の画像を添付しておきます。ぼやけるかもしれません。

課税非課税を分けているのでしたら、ループも分けるといいかもいれません。

For j = Columns("J").Column To Columns("AM").Column Step 3
For k = 2 To LastRow
If UBound(List(1)) >= k Then
If Trim(StrConv(Ws1.Cells(i, j).Value, vbNarrow)) = Trim(StrConv(List(1)(k, 1), vbNarrow)) 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 Trim(StrConv(Ws1.Cells(i, j).Value, vbNarrow)) = Trim(StrConv(List(2)(k, 1), vbNarrow)) Then
mTotal(2) = mTotal(2) + Ws1.Cells(i, j).Offset(0, 2).Value
Exit For
End If
End If
Next
Next
For j = Columns("AN").Column To Columns("BB").Column Step 3
For k = 2 To LastRow
If UBound(List(3)) >= k Then
If Trim(StrConv(Ws1.Cells(i, j).Value, vbNarrow)) = Trim(StrConv(List(3)(k, 1), vbNarrow)) 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 Trim(StrConv(Ws1.Cells(i, j).Value, vbNarrow)) = Trim(StrConv(List(4)(k, 1), vbNarrow)) Then
mTotal(4) = mTotal(4) + Ws1.Cells(i, j).Offset(0, 2).Value
Exit For
End If
End If
Next
Next