ばらばらな写真番号を連番に変更する

投稿者 : 蓬     投稿日時 : 2024/09/11(Wed) 17:03:51     OS : Windows 10     EXCEL : Excel 2019

---

撮影時についている写真番号が入っている列の隣の列に上から昇順で連番を入れたいと考えています。
写真番号が重複している場合は同じ番号を付けたいと考えています。
いろいろと試してみたのですが、重複が1,2個であればうまくできたのですがそれ以上になるとうまく番号を振り返れなくて…
皆様の知識を貸していただけないでしょうか。

【仕様】
・A列に元の写真番号,B列に変更後の写真番号を入力
・元の写真番号が同じものは変更後の写真番号も同じ番号になる
・元の写真番号が1つのセルに2つ入っているものは、変更後の写真番号も1つのセルに2つ入れる
・元写真番号が"-"のものは変更後の写真番号は空白

【イメージ】
｜　A　　｜B　｜
｜1000　 ｜1　｜
｜1010　 ｜2　｜
｜1010　 ｜2　｜
｜100,101｜3,4｜
｜512　　｜5　｜
｜　-　　｜　 ｜
｜560　　｜6　｜
｜512　　｜5　｜
｜600　　｜7　｜

一応作成中のコードを載せておきます。

Sub 写真番号()
    Dim no, noa, i, j, k As Integer
    Dim tmp As Variant
    Dim tmp2 As Variant
    
    no = 1
    
    k = Range("B" & Rows.Count).End(xlUp).Row 'データ最終行番号取得
    Range(Cells(3, 8), Cells(k, 8)).ClearContents
    
    For i = 3 To k
    
        tmp = Split(Cells(i, 7), ",")
        tmp2 = Split(Cells(i + 1, 7), ",")
        noa = UBound(tmp)
    
        If noa = 0 Then
            If Cells(i, 7) = "-" Then
                Cells(i, 8).ClearContents
                no = no + 1
            Else
                Cells(i, 8) = no
                no = no + 1
            End If
        ElseIf noa > 0 Then
            For j = 0 To noa
                Cells(i, 8) = Cells(i, 8) & no & ","
                no = no + 1
            Next j
            Cells(i, 8) = Left(Cells(i, 8), Len(Cells(i, 8)) - 1)
        End If
        

        
    Next i
    
    For i = 3 To k
        For j = i + 1 To k
        If Cells(i, 7) = Cells(j, 7) Then
            Cells(j, 8) = Cells(i, 8)
            x = j + 1
                If Cells(x, 8) = "" Then
                    x = x + 1
                End If
                Cells(x, 8) = Cells(j, 8) + 1
        End If
        Next j
    Next i
    
End Sub

投稿者 : てらてら     投稿日時 : 2024/09/11(Wed) 19:09:47

---

こんにちは。

重複がいくつあるか不明なので、総当たりしないとだめでしょう。

考え方としては、1行目のA列の写真番号を取得したら、B列に値を振り、
そのまま１行目の番号を末尾まで検索し、見つかればB列に値を記録します。

末尾まで行ったら、２行目のB列に値が無い事を確認して、B列に値を振り、末尾まで検索していきます。

これを繰返していけば良いと思います。

投稿者 : ピロリ     投稿日時 : 2024/09/11(Wed) 21:36:29

---

やり方は色々あるかと思いますが、
・このシートの 21列目以降を処理用に使用させてもらう。　･･･ 下のコードでは 定数：Col
・１つのセルに入力される「,」区切りの番号は最大10個。　･･･ 下のコードでは 定数：Max
の前提で一例です。

Sub Sample()
    Const Col As Long = 21                  'この列以降を処理用に使用します
    Const Max As Long = 10                  '１セルに入力される最大の番号数
    Dim i As Long, j As Long, cnt As Long
    Dim buf As String, tmp As Variant
    Dim r As Range
    
    Range(Cells(1, Col), Cells(1, Col + Max * 2 - 1)).EntireColumn.ClearContents  '処理範囲消去
    cnt = 1
    For i = 3 To Cells(Rows.Count, "A").End(xlUp).Row                   'A列の最終行までループ
        If Cells(i, "A") = "-" Then
            Cells(i, "B") = ""                                          '｢-｣ならば、B列は空白
        Else
            buf = ""
            tmp = Split(Cells(i, "A").Text, ",")                        'A列の旧番号を分解
            For j = 0 To UBound(tmp)                                    '１セルの番号分のループ
                Set r = Range(Cells(1, Col), Cells(1, Col + Max - 1)).EntireColumn. _
                        Find(what:=tmp(j), LookAt:=xlWhole)             '処理範囲を旧番号で検索
                If r Is Nothing Then                                    '無かったら、
                    Cells(i, Col + Max).Offset(0, j) = cnt              '新しい番号を採番
                    cnt = cnt + 1
                Else                                                    '有ったら、
                    Cells(i, Col + Max).Offset(0, j) = r.Offset(0, Max) '採番済みの番号を取得
                End If
                Cells(i, Col).Offset(0, j) = tmp(j)                     '旧番号を格納
                buf = buf & "," & Cells(i, Col + Max).Offset(0, j)      '新しい番号を合成
            Next j
            Cells(i, "B") = Mid(buf, 2)                                 '新しい番号をB列へ出力
        End If
    Next i
End Sub

投稿者 : anonymous     投稿日時 : 2024/09/13(Fri) 07:45:41

---

こんな書き方もあるでしょう。

Sub test()
    Dim dic As Object
    Dim k&, p&
    Dim s$, ss$
    Dim e
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    For k = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        s = Cells(k, "A").Value
        If s <> "" And s <> "-" Then
            ss = ""
            For Each e In Split(s, ",")
                If Not dic.exists(e) Then
                    p = p + 1
                    dic(e) = p
                    ss = ss & "," & p
                Else
                    ss = ss & "," & dic(e)
                End If
            Next
            Cells(k, "B").Value = Mid(ss, 2)
        End If
    Next
End Sub

投稿者 : 蓬     投稿日時 : 2024/09/13(Fri) 18:07:27

---

■[返信 1] てらてらさん（2024-09-11 19:09:47）の記事
＞ こんにちは。
＞
＞ 重複がいくつあるか不明なので、総当たりしないとだめでしょう。
＞
＞ 考え方としては、1行目のA列の写真番号を取得したら、B列に値を振り、
＞ そのまま１行目の番号を末尾まで検索し、見つかればB列に値を記録します。
＞
＞ 末尾まで行ったら、２行目のB列に値が無い事を確認して、B列に値を振り、末尾まで検索していきます。
＞
＞ これを繰返していけば良いと思います。
＞

ご教示いただきありがとうございます。
重複をチェックとB列の入力を同時に行うという発想がなかったです。
この方法で再度組みなおしてみます。

投稿者 : 蓬     投稿日時 : 2024/09/13(Fri) 18:10:06

---

■[返信 2] ピロリさん（2024-09-11 21:36:29）の記事
＞ やり方は色々あるかと思いますが、
＞ ・このシートの 21列目以降を処理用に使用させてもらう。　･･･ 下のコードでは 定数：Col
＞ ・１つのセルに入力される「,」区切りの番号は最大10個。　･･･ 下のコードでは 定数：Max
＞ の前提で一例です。
＞
＞
＞

ご教示いただきありがとうございます。
詳しい説明やプログラム例も教えていただきありがとうございます。
早速試してみたいと思います。

投稿者 : 蓬     投稿日時 : 2024/09/13(Fri) 18:11:14

---

■[返信 3] anonymousさん（2024-09-13 07:45:41）の記事
＞ こんな書き方もあるでしょう。
＞

ご教示いただきありがとうございます。
プログラム例も教えていただきありがとうございます。
早速試してみたいと思います。

投稿者 : 蓬     投稿日時 : 2024/09/17(Tue) 16:43:01

---

ご連絡が遅くなってしまいすみません。
無事に問題は解決いたしました。
皆様、様々な解決方法を教えていただきありがとうございました。