VBAクイズ AAAをZZZまでインクリメントする

vbaquiz_20200517_AAA2ZZZ.bas

Option Explicit

'#VBAクイズ
'出典:http://www.excel.studio-kazu.jp/kw/20200517225250.html
'> AAAの値をAAB,AAC...AAZまでインクリメントし
'> 次のアルファベットを桁上げし、ABA,ABC?ZZZまで
'> 計算するコードを書きたい
'の解答
'https://twitter.com/KotorinChunChun/status/1262026213352026112?s=20

Sub Test_ALL()
    Dim baseCll As Collection
    Set baseCll = toto_func
    
'    Debug.Print CompareCollection(baseCll, toto_func)
'    Debug.Print CompareCollection(baseCll, 変態紳士_func)
'    Debug.Print CompareCollection(baseCll, diary_func)
'    Debug.Print CompareCollection(baseCll, takatantan__func)
'    Debug.Print CompareCollection(baseCll, VBA模索中_func)
'    Debug.Print CompareCollection(baseCll, 空腹おやじ_func)
'    Debug.Print CompareCollection(baseCll, さくたん_func)
'    Debug.Print CompareCollection(baseCll, りゅうりゅう_func)
    Debug.Print CompareCollection(baseCll, kotori_func)
End Sub

Function CompareCollection(cll1 As Collection, cll2 As Collection)
    CompareCollection = False
    Dim i As Long
    For i = 1 To cll1.Count
        If i > cll2.Count Then
            Debug.Print "Fail  Last item: ", cll2.Item(i - 1)
            Exit Function
        End If
        If cll1.Item(i) <> cll2.Item(i) Then
            Debug.Print "No Match : ", cll1.Item(1), cll2.Item(i)
            Exit Function
        End If
    Next
    CompareCollection = True
End Function

'totojunique
'https://twitter.com/EasyPea69404878/status/1262067034763882499?s=20
Function toto_func() As Collection
    Dim ret As New Collection
    
    Dim i
    For i = toto_str2dec("AAA") To toto_str2dec("ZZZ")
        ret.Add toto_dec2str(i)
    Next
    
    Set toto_func = ret
End Function

Function toto_str2dec(str)
    toto_str2dec = (26 ^ 2) * (Asc(Mid(str, 3, 1)) - 65) + _
                   (26 ^ 1) * (Asc(Mid(str, 2, 1)) - 65) + _
                   (26 ^ 0) * (Asc(Mid(str, 1, 1)) - 65)
End Function

Function toto_dec2str(n)
    Dim p2, p2mod: p2 = n \ 26 ^ 2: p2mod = n Mod 26 ^ 2
    Dim p1, p1mod: p1 = p2mod \ 26 ^ 1: p1mod = p2mod Mod 26 ^ 1
    toto_dec2str = Chr(p2 + 65) & Chr(p1 + 65) & Chr(p1mod + 65)
End Function

'変態紳士
'https://twitter.com/hako_hentai/status/1262267804343885826?s=20
Function 変態紳士_func() As Collection
    Dim ret As New Collection
    
    Dim a, b, c, d
    For a = 65 To 90
        For b = 65 To 90
            For c = 65 To 90
                d = d + 1
                ret.Add Chr(a) & Chr(b) & Chr(c)
            Next
        Next
    Next
    
    Set 変態紳士_func = ret
End Function

'Excel VBA Diary
'https://twitter.com/excelvba_diary/status/1262352980054994946?s=20
Function diary_func() As Collection
    Dim ret As New Collection
    
    Dim a(25) As String, i As Long
    
    For i = 0 To 25: a(i) = Chr(65 + i): Next
    
    For i = 0 To 17575
        ret.Add a(i \ 676) & a((i \ 26) Mod 26) & a(i Mod 26)
    Next
    
    Set diary_func = ret
End Function

'takatantan
'https://twitter.com/takatantan15/status/1262292157030821890?s=20
Function takatantan__func() As Collection
    Dim ret As New Collection
    
    Dim AtoZ As Collection: Set AtoZ = New Collection
    Call takatantan_SetAlphabet(AtoZ)
    
    Dim d1, d2, d3
    
    For Each d3 In AtoZ
        For Each d2 In AtoZ
            For Each d1 In AtoZ
                ret.Add d3 & d2 & d1
            Next
        Next
    Next
    
    Set takatantan__func = ret
End Function

Sub takatantan_SetAlphabet(clt As Collection)
    Dim i
    For i = Asc("A") To Asc("Z")
        clt.Add Chr(i)
    Next
End Sub

'VBA模索中
'https://infoment.hatenablog.com/entry/2020/05/19/065737
Function VBA模索中_func() As Collection
    Dim ret As New Collection
    
    Dim i As Long
    For i = VBA模索中_DecFrom26("AAA") To VBA模索中_DecFrom26("ZZZ")
        ret.Add VBA模索中_DecTo26(i)
    Next
    
    Set VBA模索中_func = ret
End Function

' 10進法 ⇒ アルファベット
Function VBA模索中_DecTo26(source As Long) As String
    ' 商
    Dim Quotient As Long
        Quotient = source
    Dim col As Collection
    Set col = New Collection
        Do
            col.Add ((Quotient - 1) Mod 26) + 1
            Quotient = WorksheetFunction.RoundDown((Quotient - 1) / 26, 0)
            If Quotient = 0 Then
                Exit Do
            ElseIf Quotient < 27 Then
                col.Add Quotient
                Exit Do
            End If
        Loop
            
    Dim i As Long
        For i = col.Count To 1 Step -1
            VBA模索中_DecTo26 = VBA模索中_DecTo26 & Chr(col.Item(i) + 64)
        Next
End Function

' アルファベット ⇒ 10進法
Function VBA模索中_DecFrom26(source As String) As Long
    Static Dict As Object
    If Dict Is Nothing Then
        Set Dict = CreateObject("Scripting.Dictionary")
        Dim i As Long
        For i = 65 To 90
            Dict(Chr(i)) = i - 64
        Next
    End If
    
    Dim iMax As Long
    iMax = Len(source)
    Dim arr() As Variant
    ReDim arr(1 To iMax)
    For i = 1 To iMax
        arr(i) = Dict(Mid(source, i, 1)) * 26 ^ (iMax - i)
    Next
    
    VBA模索中_DecFrom26 = WorksheetFunction.Sum(arr)
End Function


'空腹おやじ
'https://twitter.com/Z1000R_LR/status/1262352790229118976?s=20
Function 空腹おやじ_func() As Collection
    Dim ret As New Collection
    
    Dim s As String
    s = "AAA"
    Do
        ret.Add s
        s = incrementAlpha(s)
        If s = "ZZZ" Then Exit Do
    Loop
    ret.Add s
    
    Set 空腹おやじ_func = ret
End Function
    
Function incrementAlpha(ByVal sValue As String) As String

    Dim lValue As Long
    
    lValue = toDec(sValue) + 1
    
    incrementAlpha = toAlpha(lValue)
    
End Function

Function decrementAlpha(ByVal sValue As String) As String

    Dim lValue As Long
    
    lValue = toDec(sValue) - 1
    
    decrementAlpha = toAlpha(lValue)
    
End Function

Function toDec(ByVal sAlpha As String) As Long

    Dim lLen As Long
    Dim i   As Long
    
    lLen = Len(sAlpha)
    
    For i = lLen To 1 Step -1
        toDec = toDec + (Asc(Mid$(sAlpha, i, 1)) - Asc("A") + 1) * 26 ^ (lLen - i)
    Next
    
End Function

Function toAlpha(ByVal lValue As Long) As String

    Dim lSubIndex As Long
    
    Do Until lValue = 0
        lSubIndex = (lValue - 1) Mod 26
        toAlpha = Chr(Asc("A") + lSubIndex) & toAlpha
        lValue = (lValue - 1) \ 26
    Loop
    
End Function

'さくたん
'https://twitter.com/sakutan2020/status/1262043478256570368?s=20
Function さくたん_func() As Collection
    Dim ret As New Collection
    
    Dim i As Long
    For i = 0 To 17575 '26 ^ 2 - 5 To 26 ^ 2 + 5
        Dim str(1 To 3) As String
        str(3) = Chr(i \ (26 ^ 2) + 65)
        str(2) = Chr((i Mod (26 ^ 2)) \ 26 + 65)
        str(1) = Chr((i Mod (26 ^ 2)) Mod 26 + 65)
        Dim pos As Long
        Dim msg As String
        For pos = 3 To 1 Step -1
            msg = msg & str(pos)
        Next
        ret.Add msg
        msg = ""
    Next
    
    Set さくたん_func = ret
End Function

'りゅうりゅう
Function りゅうりゅう_func() As Collection
    Dim ret As New Collection
    
    Dim i               As Long
    For i = 703 To 16384
        ret.Add Replace(Replace(Cells(1, i).Address, "$", ""), "1", "")
    Next
    
    Set りゅうりゅう_func = ret
End Function

'AAAをZZZまでインクリメント

'ことりちゅん
Function kotori_func() As Collection
    Dim ret As New Collection
    
    Dim i
    For i = kotori_str2dec("AAA") To kotori_str2dec("ZZZ")
        ret.Add kotori_dec2str(i)
'        Debug.Print kotori_dec2str(i)
    Next
    
    Set kotori_func = ret
End Function

Function kotori_str2dec(str)
    Dim str123ABC: str123ABC = ReplaceSingle(str, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "0123456789ABCDEFGHIJKLMNOP")
    kotori_str2dec = WorksheetFunction.Decimal(str123ABC, 26)
End Function

Function kotori_dec2str(num)
    Dim strABCDEF: strABCDEF = Right("00" & WorksheetFunction.Base(num, 26), 3)
    kotori_dec2str = ReplaceSingle(strABCDEF, "0123456789ABCDEFGHIJKLMNOP", "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
End Function

Rem 指定した単一文字毎に一括で置換する。
Rem  @param base_str   変換元文字列
Rem  @param find_str   検索文字（１字づつ続けて記述）
Rem  @param repl_str   置換文字（１字づつ続けて記述）
Function ReplaceSingle(ByVal base_str As String, find_str As String, repl_str As String) As String
    Dim retVal As String: retVal = base_str

    Dim i As Long, j As Long
    For j = 1 To Len(base_str)
        For i = 1 To Len(find_str)
            If Mid(retVal, j, 1) = Mid(find_str, i, 1) Then
                Mid(retVal, j, 1) = Mid(repl_str, i, 1)
                Exit For
            End If
        Next
    Next
    
    ReplaceSingle = retVal
End Function