[[20190218132930]]　『欠番を調べたい』（もち）　ページの最後に飛ぶ

『欠番を調べたい』（もち）

シート１／Ｘ列：備考欄に入力されている「番号」に欠番がないか目視で確認しているのですが、自動で欠番が分かる方法があったら教えてください。

・Ｘ列：備考欄には番号以外にも入力有り。
「番号.日付」(例)001.3/26　、　「番号.日付[コメント]」(例)002.3/26[注意事項参照]
・必ず番号が先頭に入力されている。
・番号が連番で入力されている場合もある。
その場合、番号のどちらか一方、または両方の番号の後ろに文字が入力される。
「番号文字-番号文字.日付」(例)003SU-004／003-004選／003得-004TS　など
・B列：エリアごとに欠番を調べたい

B列：エリア　　　Ｘ列：備考欄
東京　　　　　　　001.3/26[注意事項参照]
東京　　　　　　　002.3/26
東京　　　　　　　003ＳＵ-004.3/28
東京　　　　　　　006-007得.4/1
埼玉　　　　　　　001.3/20[要確認]
埼玉　　　　　　　003選-004YS.3/25

↓　↓

＜欠番＞
東京　005
埼玉　002

＜使用 Excel：Excel2010、使用 OS：unknown ＞

 備考欄への入力で、
 １）数値が連続で3桁続くものを番号とみなす
 ２）000は存在しない
 という条件で、以下のコードでどうでしょう？
 結果はA列に返します。
    Sub test()
        Dim m As Variant
        Dim i As Long, j As Long, n As Long
        Dim a As Variant
        Dim dic As Object
        Dim k As Variant
        Set dic = CreateObject("Scripting.Dictionary")
        With CreateObject("VBScript.RegExp")
            .Global = True
            .Pattern = "[0-9]{3}"
            For i = 2 To Cells(Rows.Count, "X").End(xlUp).Row
                If .test(Cells(i, "X").Value) Then
                    If Not dic.exists(Cells(i, "B").Value) Then
                        ReDim a(999)
                    Else
                        a = dic(Cells(i, "B").Value)
                    End If
                    For Each m In .Execute(Cells(i, "X").Value)
                        a(CInt(m)) = a(CInt(m)) + 1
                        If a(0) < CInt(m) Then a(0) = CInt(m)
                    Next m
                    dic(Cells(i, "B").Value) = a
                End If
            Next i
        End With
        n = 1
        Range("AA:AA").ClearContents
        For Each k In dic.keys
            a = dic(k)
            For j = 1 To a(0)
                Select Case a(j)
                    Case 1      'OK
                    Case Is > 1: Cells(n, "AA").Value = k & " " & Format(j, "000") & " 重複": n = n + 1
                    Case "":     Cells(n, "AA").Value = k & " " & Format(j, "000") & " 欠番": n = n + 1
                End Select
            Next j
        Next k
    End Sub

（稲葉） 2019/02/18(月) 15:02

 ＞・番号が連番で入力されている場合もある。 
 これって、Xの5行目
 東京　　　　　　　006-007得.4/1 
 が
 東京　　　　　　　005-007得.4/1 
 このように、3つの番号またがることはないんですかね？
 考慮してないけど、そういうときどうしよう・・・
（稲葉） 2019/02/18(月) 15:21

Sub main()

    Dim dt(999) As String, dic As Object, k As Variant, i As Long, c As Range, f As String
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 999 To 1 Step -1
        With Range("X:X")
            Set c = .Find(Format(i, "000"), , , xlPart)
            If Not c Is Nothing Then
                dt(i) = dt(i) & vbLf & c.EntireRow.Cells(1)
                If dic(c.EntireRow.Cells(1).Value) = "" Then dic(c.EntireRow.Cells(1).Value) = i
                f = c.Address
                    Do
                        Set c = .FindNext(c)
                        dt(i) = dt(i) & vbLf & c.EntireRow.Cells(1)
                        If dic(c.EntireRow.Cells(1).Value) = "" Then dic(c.EntireRow.Cells(1).Value) = i
                    Loop While Not c Is Nothing And c.Address <> f
            End If
        End With
    Next i
    For Each k In dic.keys
        For i = dic(k) To 1 Step -1
            If InStr(dt(i), k) = 0 Then MsgBox "欠番：" & k & Format(i, "000")
        Next i
    Next k
End Sub
（mm） 2019/02/18(月) 15:40

 UDF
 セルに
 =IFERROR(GetMissings($B$2:$B$100,$X$2:$X$100,ROW($A1),COLUMN(A$1)),"")
 として、右隣へコピー後、下方コピー

 Function GetMissings(rng1 As Range, rng2 As Range, RowRef As Long, ColRef As Long)
     Dim a, b, e, i As Long, ii As Long, m As Object, dic As Object, x, AL As Object
     Set dic = CreateObject("Scripting.Dictionary")
     GetMissings = CVErr(2404)
     a = rng1.Value: b = rng2.Value
     With CreateObject("VBScript.RegExp")
         .Global = True
         .Pattern = "(^|-)(\d+)"
         For i = 1 To UBound(a, 1)
             If a(i, 1) <> "" Then
                 If Not dic.exists(a(i, 1)) Then
                     dic(a(i, 1)) = Array(CreateObject("System.Collections.ArrayList"), Empty, Empty)
                 End If
                 If .test(b(i, 1)) Then
                     For Each m In .Execute(b(i, 1))
                         If Not dic(a(i, 1))(0).Contains(Val(m.submatches(1))) Then
                             dic(a(i, 1))(0).Add Val(m.submatches(1))
                         End If
                         If IsEmpty(dic(a(i, 1))(1)) Then dic(a(i, 1)) = _
                             Array(dic(a(i, 1))(0), String(Len(m.submatches(1)), "0"), Empty)
                     Next
                 End If
             End If
         Next
     End With
     If RowRef <= dic.Count Then
         ReDim x(dic.Count - 1, 1)
         For i = 0 To dic.Count - 1
             x(i, 0) = dic.keys()(i)
             Set AL = dic.items()(i)(0).Clone
             If AL.Count > 1 Then
                 AL.Sort
                 For ii = AL(0) To AL(AL.Count - 1)
                     If Not AL.Contains(CDbl(ii)) Then
                         x(i, 1) = x(i, 1) & IIf(x(i, 1) <> "", ", ", "") & _
                         Format$(ii, dic.items()(i)(1))
                     End If
                 Next
             End If
             If i + 1 = RowRef Then
                 If ColRef = 1 Then
                     GetMissings = x(RowRef - 1, 0)
                 Else
                     GetMissings = x(RowRef - 1, 1)
                 End If
                 Exit For
             End If
         Next
     End If
 End Function

（seiya） 2019/02/18(月) 15:54

私も作ってみました。重複探しには未対応で、欠番探しのみです。

 Sub test()
    Dim DIC1 As Object
    Dim DIC2 As Object
    Dim vw As Variant
    Dim cw As String
    Dim i As Long
    Dim j As Long
    Dim iR As Long

    Columns("AA").ClearContents
    Set DIC1 = CreateObject("Scripting.Dictionary")
    Set DIC2 = CreateObject("Scripting.Dictionary")
    For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
        vw = Split(Cells(i, "X").Text, "-")
        For j = Left(vw(0), 3) To Left(vw(UBound(vw)), 3)
            cw = Cells(i, "B").Value
            If DIC1(cw) < j Then
                DIC1(cw) = j
            End If
            DIC2(cw & " " & Format(j, "000")) = j
        Next j
    Next i
    For i = 0 To DIC1.Count - 1
        For j = 1 To DIC1.items()(i)
            cw = DIC1.keys()(i) & " " & Format(j, "000")
            If DIC2.exists(cw) = False Then
                iR = iR + 1
                Cells(iR, "AA").Value = cw
            End If
        Next j
    Next i
 End Sub
（???） 2019/02/18(月) 16:08

コメント返信：

[ 一覧(最新更新順) ]

[[20190218132930]] 『欠番を調べたい』（もち） ページの最後に飛ぶ

[[20190218132930]]　『欠番を調べたい』（もち）　ページの最後に飛ぶ