VBA セルに特定の条件で番号を付与したい

前提・実現したいこと

現在VBAにて、セル情報の条件に応じて、番号を付与する物を作っています。
ボタンを押して同じ店、地域の場合は同じ番号が入り、同じ店ででも地域が違う場合は次の番号が入るようにし、数量が0の場合は空白がはいるように実装を考えています。

発生している問題・エラーメッセージ

現在上と下の店と地域を比較して違う場合は数字を入れる等して取込番号を決めているのですが、そもそもお店のすべての数量が0の場合、取込番号はそのままにしたいのですが、上下で比較したタイミングで番号を＋１している為、数字が抜けて表示されてしまいます。

該当のソースコード

Sub 取込番号を付与()

'変数を宣言し、初期数字を設定
Dim lastrow As Long
Dim torikomi As Long: torikomi = 1
Dim cnt As Long: cnt = 1
Dim startrow As Long: startrow = 3
Dim com1cnt As Long: com1cnt = 2
Dim com2cnt As Long: com2cnt = 3
Dim suryocnt As Long: suryocnt = 3
Dim toriflg As Long: toriflg = 0

'最終行からCtrl + ↑ を押して最終列をカウント(取込番号は空白の可能性があるので店コードの列で確認)
lastrow = Worksheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row

'最終行まで到達したら、ループを抜ける
Do While cnt < lastrow - 1

    If suryo <= 0 Then
        Worksheets("Sheet1").Range("A" & startrow).Value = ""
        
        Else
            Worksheets("Sheet1").Range("A" & startrow).Value = torikomi
                                    
    End If
    
    'それぞれの数値をカウントアップする
    cnt = cnt + 1
    startrow = startrow + 1
    com1cnt = com1cnt + 1
    com2cnt = com2cnt + 1
    suryocnt = suryocnt + 1
    
    'カウントアップした結果のExcel情報を取得
    com1 = Worksheets("Sheet1").Range("B" & com1cnt).Value
    com2 = Worksheets("Sheet1").Range("B" & com2cnt).Value
    suryo = Worksheets("Sheet1").Range("H" & suryocnt).Value
    tokui1 = Worksheets("Sheet1").Range("C" & com1cnt).Value
    tokui2 = Worksheets("Sheet1").Range("C" & com2cnt).Value

    '店CDと地域CDが同じ場合と数量が0の場合は何もしないが違う場合は取込番号を+1する
    If com1 = com2 And tokui1 = tokui2 Then
            
        ElseIf com1 = com2 And tokui1 <> tokui2 Then
            torikomi = torikomi + 1
            
        ElseIf com1 <> com2 And tokui1 <> tokui2 Then
            torikomi = torikomi + 1
            
        Else
            
    End If
    
   
Loop

End Sub

試したこと

フラグを管理して、上下で変更があった場合に+1にして数量の結果を別でカウントし、結果が全て0だった場合、-1にするという事を考えて試してみましたが、うまくいきませんでした。

補足情報（FW/ツールのバージョンなど）

Excel 2016 で実行しています。

行動規範の内容に同意します

回答1件

ベストアンサー

コメントを受け、再度修正しました。こんな感じでどうでしょうか。

vba
1Sub sample()
2    Dim ws As Worksheet
3    Set ws = Worksheets("Sheet1")
4    Dim lastrow
5    lastrow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
6    Dim i, torikomi
7    For i = 3 To lastrow
8        If ws.Cells(i, 2) & vbTab & ws.Cells(i, 3) <> ws.Cells(i - 1, 2) & vbTab & ws.Cells(i - 1, 3) Then
9            If WorksheetFunction.SumIfs(ws.Columns(8), ws.Columns(2), ws.Cells(i, 2), ws.Columns(3), ws.Cells(i, 3)) > 0 Then torikomi = torikomi + 1
10        End If
11        ws.Cells(i, 1) = IIf(ws.Cells(i, 8) > 0, torikomi, "")
12    Next
13End Sub

投稿2021/08/27 08:46

編集2021/08/29 06:26

jinoji

総合スコア4585

vba_bigi

2021/08/27 14:15

確認させていただきました。すみません、こちらの質問と画像が拙い感じでした。それぞれ数量が入っている行に関しては同じ取り込み番号を表示したいと思っています。 (画像の13行と14行目のイメージになります。) 同じ会社で数量が入っていれば同じ取り込み番号を表示して、数量が0の行は空白で何も表示しないようにしようと考えています。