Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
VBAクイズ AAAをZZZまでインクリメントする
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 検索文字(1字づつ続けて記述
Rem @param repl_str 置換文字(1字づつ続けて記述
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.