Продолжаю искать самые скоростные приёмы работы в VBA
Скрины
Код
Код
Option Explicit
Option Private Module
'====================================================================================================
Sub Start()
Tester 3, 1000
End Sub
'====================================================================================================
Sub Tester(Optional iType0To3&, Optional nCycles& = 1)
Dim x, arrNum(), arrLtr() As String
Dim t!, c&, c1&, c2&, i&, n&
If iType0To3 = 1 Then
c1 = 1: c2 = 26: ' A-Z
ElseIf iType0To3 = 2 Then
c1 = 27: c2 = 702: ' AA-ZZ
ElseIf iType0To3 = 3 Then
c1 = 703: c2 = Columns.Count ' AAA-End
ElseIf iType0To3 = 4 Then
c1 = 1: c2 = Columns.Count ' ALL (A-End 16 384 columns)
Else
Err.Raise xlErrNA
End If
ReDim arrNum(c2 - c1): i = -1
ReDim arrLtr(UBound(arrNum))
't = Timer
For c = c1 To c2
i = i + 1
arrNum(i) = c
arrLtr(i) = ByAddress_Left(c)
Next c
'Debug.Print "GetTrueList", 1000 * (Timer - t), String$(50, "=")
t = Timer
For n = 1 To nCycles
For i = 0 To UBound(arrNum)
If MSdoc(arrNum(i)) <> arrLtr(i) Then MsgBox MSdoc(arrNum(i)) & "<>" & arrLtr(i): Exit Sub
Next i
Next n
Debug.Print "MSdoc", 1000 * (Timer - t)
t = Timer
For n = 1 To nCycles
For i = 0 To UBound(arrNum)
If iDo(arrNum(i)) <> arrLtr(i) Then MsgBox iDo(arrNum(i)) & "<>" & arrLtr(i): Exit Sub
Next i
Next n
Debug.Print "iDo", 1000 * (Timer - t)
t = Timer
For n = 1 To nCycles
For i = 0 To UBound(arrNum)
If Recur(arrNum(i)) <> arrLtr(i) Then MsgBox Recur(arrNum(i)) & "<>" & arrLtr(i): Exit Sub
Next i
Next n
Debug.Print "Recur", 1000 * (Timer - t)
End Sub
'====================================================================================================
'====================================================================================================
Function ByAddress_Left(ByVal nCol&) As String ' выбывает из-за медлительности
Dim tx$
tx = Columns(nCol).Address(0, 0, xlA1)
ByAddress_Left = Left$(tx, InStr(tx, ":") - 1)
End Function
'====================================================================================================
Function ByAddress_Split(ByVal nCol&) As String ' выбывает из-за медлительности (медленнее, чем Left)
ByAddress_Split = Split(Columns(nCol).Address(0, 0, xlA1), ":")(0)
End Function
'====================================================================================================
' https://docs.microsoft.com/ru-ru/office/troubleshoot/excel/convert-excel-column-numbers
Function MSdoc(ByVal nCol&) As String
Dim a&, b&
Do While nCol > 0
a = Int((nCol - 1) / 26)
b = (nCol - 1) Mod 26
MSdoc = Chr$(b + 65) & MSdoc
nCol = a
Loop
End Function
'====================================================================================================
'====================================================================================================
' https://overcoder.net/q/5750/%D1%84%D1%83%D0%BD%D0%BA%D1%86%D0%B8%D1%8F-%D0%B4%D0%BB%D1%8F-%D0%BF%D1%80%D0%B5%D0%BE%D0%B1%D1%80%D0%B0%D0%B7%D0%BE%D0%B2%D0%B0%D0%BD%D0%B8%D1%8F-%D0%BD%D0%BE%D0%BC%D0%B5%D1%80%D0%B0-%D1%81%D1%82%D0%BE%D0%BB%D0%B1%D1%86%D0%B0-%D0%B2-%D0%B1%D1%83%D0%BA%D0%B2%D1%83
'====================================================================================================
Function OneTwoThree(ByVal nCol&) As String ' выбыл из-за некорректного преобразования
If nCol < 27 Then OneTwoThree = Chr$(64 + nCol): Exit Function 'A
If nCol < 677 Then OneTwoThree = Chr$(64 + Int(nCol / 26)) & Chr$(64 + nCol - (Int(nCol / 26) * 26)): Exit Function ' AA
OneTwoThree = Chr$(64 + Int(nCol / 676)) & Chr$(64 + Int(nCol - Int(nCol / 676) * 676) / 26) & Chr$(64 + nCol - (Int(nCol - Int(nCol / 676) * 676) / 26) * 26) ' AAA
End Function
'====================================================================================================
Public Function JanW(ByVal nCol&) As String ' выбыл из-за переполнения стэка
JanW = JanW(Int((nCol - 1) / 26)) & Chr$(((nCol - 1) Mod 26) + Asc("A"))
End Function
'====================================================================================================
Function iDo(ByVal nCol&) As String
Dim s$, n&, c As Byte
n = nCol
Do
c = ((n - 1) Mod 26)
s = Chr$(c + 65) & s
n = (n - c) \ 26
Loop While n > 0
iDo = s
End Function
'====================================================================================================
Function Recur(ByVal nCol&) As String
Dim lAlpha&, lRemainder&
If nCol <= 26 Then Recur = Chr$(nCol + 64): Exit Function
lRemainder = nCol Mod 26
lAlpha = Int(nCol / 26)
If lRemainder = 0 Then lRemainder = 26: lAlpha = lAlpha - 1
Recur = Recur(lAlpha) & Chr$(lRemainder + 64)
End Function
'====================================================================================================
Function Recur2(ByVal nCol&) As String ' выбыл из-за некорректного преобразования
Dim iAlpha&, iRemainder&
iAlpha = Int(nCol / 27)
iRemainder = nCol - (iAlpha * 26)
If iAlpha > 0 Then Recur2 = Chr$(iAlpha + 64)
If iRemainder > 0 Then Recur2 = Recur2 & Chr$(iRemainder + 64)
End Function
'====================================================================================================
Вывод: общая скорость работы, а также двукратный выигрыш на первых 26 однобуквенных столбцах позволяет сказать, что предпочтительнее использовать рекурсивную функцию, в качестве основной
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 17.08.2019
24.05.2021 13:17:48
Здравствуйте, может можно определить. Application.ConvertFormula method (Excel) Добавлено:
Код
Sub Number2Letter()
'PURPOSE: Convert a given number into it's corresponding Letter Reference
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
Dim ColumnNumber As Long
Dim ColumnLetter As String
'Input Column Number
ColumnNumber = InputBox("Type column number")
'Convert To Column Letter
ColumnLetter = Split(Cells(1, ColumnNumber).Address, "$")(1)
'Display Result
MsgBox "Column " & ColumnNumber & " = Column " & ColumnLetter
End Sub
DANIKOLA, ну попробуйте Не понимаю, причём тут конвертация формулы, но с нетерпением жду результатов сравнения по скорости
Инфо
Таблица сравнения
Код
Код
Option Explicit
Option Private Module
'====================================================================================================
Sub Start()
Dim i&
'Tester 1, "kaz": Exit Sub
shComp.Range("B3:E7").ClearContents
For i = 1 To 4
Tester i
Next i
End Sub
'====================================================================================================
Sub Tester(iType1To4&, Optional txCDMR$)
Dim arr(), arrTime() As Long, arrNum() As Long, arrLtr() As String
Dim nCyc&, c&, c1&, c2&, i&
If iType1To4 = 1 Then
c1 = 1: c2 = 26: ' A-Z
nCyc = 100000
ElseIf iType1To4 = 2 Then
c1 = 27: c2 = 702: ' AA-ZZ
nCyc = 1000
ElseIf iType1To4 = 3 Then
c1 = 703: c2 = Columns.Count ' AAA-End
nCyc = 100
ElseIf iType1To4 = 4 Then
c1 = 1: c2 = Columns.Count ' ALL (A-End 16 384 columns)
nCyc = 100
Else
Err.Raise xlErrNA
End If
ReDim arrNum(c2 - c1): i = -1
ReDim arrLtr(UBound(arrNum))
For c = c1 To c2
i = i + 1
arrNum(i) = c
arrLtr(i) = ByAddress_Left(c)
Next c
If Len(txCDMR) Then
Debug.Print iType1To4, txCDMR, FuncTest(txCDMR, nCyc, arrNum, arrLtr): Exit Sub
End If
arr = Array("c", "d", "m", "r")
ReDim arrTime(1 To UBound(arr) + 2, 1 To 1)
arrTime(1, 1) = nCyc
For i = 0 To UBound(arr)
arrTime(i + 2, 1) = FuncTest(arr(i), nCyc, arrNum, arrLtr)
Next i
shComp.Cells(3, iType1To4 + 1).Resize(UBound(arrTime), 1).Value2 = arrTime
End Sub
'====================================================================================================
'====================================================================================================
Function FuncTest(ByVal txCDMR$, nCycles&, arrNum() As Long, arrLtr() As String) As Long
Dim tx$, t!, cyc&, i&
Dim fCol As Boolean, fDo As Boolean, fMS As Boolean, fRec As Boolean
tx = LCase$(txCDMR)
If tx = "c" Then fCol = True: txCDMR = "ColNumToLtr": GoTo nx
If tx = "d" Then fDo = True: txCDMR = "iDo": GoTo nx
If tx = "m" Then fMS = True: txCDMR = "MSdoc": GoTo nx
If tx = "r" Then fRec = True: txCDMR = "Recur": GoTo nx
Err.Raise xlErrNA
nx: t = Timer
For cyc = 1 To nCycles
For i = 0 To UBound(arrNum)
If fCol Then
tx = ColNumToLtr(arrNum(i))
ElseIf fDo Then
tx = iDo(arrNum(i))
ElseIf fMS Then
tx = MSdoc(arrNum(i))
ElseIf fRec Then
tx = Recur(arrNum(i))
End If
If tx <> arrLtr(i) Then MsgBox tx & "<>" & arrLtr(i), vbCritical, txCDMR: Exit Function
Next i
Next cyc
FuncTest = 1000 * (Timer - t)
End Function
'====================================================================================================
'====================================================================================================
Function ColNumToLtr(ByVal nCol&) As String
If nCol < 703 Then
ColNumToLtr = Recur(nCol)
Else
ColNumToLtr = iDo(nCol)
End If
End Function
'----------------------------------------------------------------------------------------------------
Function iDo(ByVal nCol&) As String
Dim s$, n&, c&
n = nCol
Do
c = ((n - 1) Mod 26)
s = Chr$(c + 65) & s
n = (n - c) \ 26
Loop While n > 0
iDo = s
End Function
'----------------------------------------------------------------------------------------------------
' https://docs.microsoft.com/ru-ru/office/troubleshoot/excel/convert-excel-column-numbers
Function MSdoc(ByVal nCol&) As String
Dim a&, b&
Do While nCol > 0
a = Int((nCol - 1) / 26)
b = (nCol - 1) Mod 26
MSdoc = Chr$(b + 65) & MSdoc
nCol = a
Loop
End Function
'----------------------------------------------------------------------------------------------------
Function Recur(ByVal nCol&) As String
Dim lAlpha&, lRemainder&
If nCol <= 26 Then Recur = Chr$(nCol + 64): Exit Function
lRemainder = nCol Mod 26
lAlpha = Int(nCol / 26)
If lRemainder = 0 Then lRemainder = 26: lAlpha = lAlpha - 1
Recur = Recur(lAlpha) & Chr$(lRemainder + 64)
End Function
'====================================================================================================
'====================================================================================================
Function ByAddress_Left(ByVal nCol&) As String ' выбывает из-за медлительности
Dim tx$
tx = Columns(nCol).Address(0, 0, xlA1)
ByAddress_Left = Left$(tx, InStr(tx, ":") - 1)
End Function
'====================================================================================================
Function ByAddress_Split(ByVal nCol&) As String ' выбывает из-за медлительности (медленнее, чем Left)
ByAddress_Split = Split(Columns(nCol).Address(0, 0, xlA1), ":")(0)
End Function
'====================================================================================================
'====================================================================================================
Sub t()
MsgBox Kaz(26)
End Sub
Function Kaz(ByVal col&) As String ' выбыл из-за некорректного преобразования
Do
Kaz = Chr$(64 + col Mod 26) & Kaz
col = col \ 26
Loop Until col = 0
End Function
'====================================================================================================
' https://overcoder.net/q/5750/%D1%84%D1%83%D0%BD%D0%BA%D1%86%D0%B8%D1%8F-%D0%B4%D0%BB%D1%8F-%D0%BF%D1%80%D0%B5%D0%BE%D0%B1%D1%80%D0%B0%D0%B7%D0%BE%D0%B2%D0%B0%D0%BD%D0%B8%D1%8F-%D0%BD%D0%BE%D0%BC%D0%B5%D1%80%D0%B0-%D1%81%D1%82%D0%BE%D0%BB%D0%B1%D1%86%D0%B0-%D0%B2-%D0%B1%D1%83%D0%BA%D0%B2%D1%83
Function OneTwoThree(ByVal nCol&) As String ' выбыл из-за некорректного преобразования
If nCol < 27 Then OneTwoThree = Chr$(64 + nCol): Exit Function 'A
If nCol < 677 Then OneTwoThree = Chr$(64 + Int(nCol / 26)) & Chr$(64 + nCol - (Int(nCol / 26) * 26)): Exit Function ' AA
OneTwoThree = Chr$(64 + Int(nCol / 676)) & Chr$(64 + Int(nCol - Int(nCol / 676) * 676) / 26) & Chr$(64 + nCol - (Int(nCol - Int(nCol / 676) * 676) / 26) * 26) ' AAA
End Function
'====================================================================================================
Public Function JanW(ByVal nCol&) As String ' выбыл из-за переполнения стэка
JanW = JanW(Int((nCol - 1) / 26)) & Chr$(((nCol - 1) Mod 26) + Asc("A"))
End Function
'====================================================================================================
Function Recur2(ByVal nCol&) As String ' выбыл из-за некорректного преобразования
Dim iAlpha&, iRemainder&
iAlpha = Int(nCol / 27)
iRemainder = nCol - (iAlpha * 26)
If iAlpha > 0 Then Recur2 = Chr$(iAlpha + 64)
If iRemainder > 0 Then Recur2 = Recur2 & Chr$(iRemainder + 64)
End Function
'====================================================================================================
Дополнил и автоматизировал процесс сравнения (тестовый стенд) — есть кнопка в левом верхнем углу Попробовал написать универсальную функцию (ColNumToLtr), использующую две других, в зависимости от номера столбца, но безуспешно — по-прежнему проще и быстрее использовать рекурсивную функцию
UPD: нашёл архивную тему - способы, описанные там и близко по скорости не сравнятся с описанными + некорректно преобразовывает некоторые числа (например, 26) — добавил в коды
UPD2: DANIKOLA, Ваш метод есть в списке и он самый медленный из тестируемых и один из самых очевидных Кроме того, он не имеет отношения к ConvertFormula - не вводите в заблуждение и откорректируйте сообщение И спасибо, что прямо отвечаете на вопрос
Изменено: - 25.05.2021 08:08:08
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 01.01.1970
24.05.2021 15:03:24
однако...
Код
Function NColumnToLtr$(c&)
Dim a$
If c > Columns.Count Then Exit Function Else a = Cells(1, c).Address(0, 0)
NColumnToLtr = Left(a, Len(a) - 1)
End Function
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
Function ByAddress_Left(ByVal nCol&) As String ' выбывает из-за медлительности
Dim tx$
tx = Columns(nCol).Address(0, 0, xlA1)
ByAddress_Left = Left$(tx, InStr(tx, ":") - 1)
End Function
• эта функция более 3ёх раз медленнее, чем 3 финальные • при этом сравнима с вашей по скорости • НЕ только для первых 26 столбцов из одной буквы, в отличие от вашей
Ну и в целом, если есть If c > Columns.Count, то почему нет If c < 1?
Изменено: - 24.05.2021 15:12:06
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 15.09.2012
24.05.2021 15:31:11
А для чего? Неужели есть такая необходимость - обрабатывать в коде десятки-сотни тысяч раз определение имени столбца, а не его номера?
с неохотой ждал этого вопроса, но думал, что его задаст Миша Эта тема, как и некоторые другие мои темы - одна цепочка разработки ускорения работы с диапазонами (если Виталий напишет функцию, то будет отлично, но альтернативы должны быть, да и интересно это)
Отвлёкся… Нужно это для отбора ячеек по критерию, в качестве замены штатной Range.Address — она не очень шустрая Вот Андрей как раз этот подход использует (собственно, после этого я задумал исследовать этот момент и использовать), …
… и он даёт ощутимый прирост, т.к., если область большая, то гораздо быстрее использовать счётчик для строк и подобное преобразование для столбцов, чем для каждой подходящей ячейки получать Cell.Address
На всякий случай: использовать стиль ссылок R1C1, чтобы не вычислять буквы столбца не получится, т.к. диапазон из такого адреса не сформировать
Изменено: - 25.05.2021 08:11:26
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 01.01.1970
24.05.2021 16:25:35
как в формулах предпочитаю R1C1 так же и в VBA при необходимости обратиться к ячейке, диапазону, постоянно использую Сells(r,c) и практически никогда Range("ADF12"), поэтому был слегка удивлен темой
Цитата
Jack Famous написал: даёт ощутимый прирост, т.к., если область большая,
а после этой фразы - сильно удивлен. а можно пример, где это реально потребовалось, в какой практической задаче? и код, как это было реализовано?
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
Алексей, если абстрагироваться от задачи , то вопрос в реализации наибыстрого преобразовния десятичного числа в систему счисления по основанию N, где N в данном случае 26. тут нужно реально взвешивать затраты на расчет и на написание. например более краткий чем у Игоря вариант
Код
Function NColumnToLtr$(c&)
If c > Columns.Count Then Exit Function Else NColumnToLtr = Replace(Cells(1, c).Address(0, 0),"1","")
End Function
но будет чуть дольше и я согласен с Игорем и Виктором, не понятен смысл упражнения. Некий МШ - давайте у кого быстрее, а зачем придумаем потом.
раньше я собирал адреса по подходящим данным из массива как rng.Areas(n).Cells(r,c).Address - для каждой подходящей ячейки. Теперь мне достаточно определить номер столбца первой ячейки в каждой области и далее счётчик и эта функция преобразования позволит получить тот же адрес, но быстрее. Чем больше области, тем заметнее будет выигрыш Всё. В этом для меня сейчас и заключена практическая полезность. Рассматривать тему как простое соревнование ХЗ зачем - меня тоже устроит, т.к. главное выяснить, все ли способы я перебрал и нет ли пошустрее варианта
UPD2 (всем): Если не поняли, зачем это нужно, то прошу больше не искать конечную цель Вы вправе считать, что всё можно сделать не так, а гораздо проще, легче и быстрее В доказательство своих слов я дал ссылки на свои темы с тестами, поэтому, если можете доказать, то прошу это делать исключительно на языке кода и в соответствующих местах (темах). Можете считать эту тему соревнованием без какой-либо цели. Просто "кто быстрее"
Изменено: - 25.05.2021 08:09:20
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Jack Famous написал: rng.Areas(n).Cells(r,c).Address - для каждой ячейки.
- для каждой ячейки! вот же ж круто! а зачем? я всегда получал адрес области так: rng.Areas(n).Address Areas - это Range и Address - возвращает адрес этого диапазона ячеек (не нужно вычислять 1-ю, не нужно калькулировать с Count не нужно считать по одной)
появляются вопросы? формулируйте задачу, которую решаете, а не способ, которым придумали ее решать кто-то поймет суть задачи - напишет ответ а пока никто не понимает ДЛЯ ЧЕГО НУЖНО вычислять буквенное имя столбца, никто и не подумает его вычислять
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
Все же перевел (specially for you) на VBA в части определения буквы столбца (проверь по скорости со своими решениями)
Код
Sub test()
Debug.Print R1C1toA1(1, 16000)
End Sub
Function R1C1toA1(rw As Long, col As Long) As String 'номер столбца в букву
Dim A1(0 To 5) As Byte, i As Long, col3 As Long, col2 As Long, col1 As Long
i = 0
col3 = col \ 676 '(26 * 26)
If col3 > 0 Then A1(i * 2) = col3 + 64: i = i + 1
col2 = (col / 26) - col3 * 26
If col2 > 0 Then A1(i * 2) = col2 + 64: i = i + 1
col1 = col Mod 26
A1(i * 2) = col1 + 64
R1C1toA1 = A1
End Function
Наконец-то нормальная дискуссия bedvit, не хватает закрывающей кавычки - пишет "A <> "A" + не понял, нафига в функции номер строки, убрал (и нет - выдаёт неправильно НЕ из-за того, что я убрал)
Код
Код
Option Explicit
Option Private Module
'====================================================================================================
Sub Start()
Dim i&
'Tester 1, "kaz": Exit Sub
shComp.Range("B3:E7").ClearContents
For i = 1 To 4
If Not Tester(i) Then Exit Sub
Next i
End Sub
'====================================================================================================
Function Tester(iType1To4&, Optional txCDMR$) As Boolean
Dim arr(), arrTime() As Long, arrNum() As Long, arrLtr() As String
Dim nCyc&, c&, c1&, c2&, i&
If iType1To4 = 1 Then
c1 = 1: c2 = 26: ' A-Z
nCyc = 100000
ElseIf iType1To4 = 2 Then
c1 = 27: c2 = 702: ' AA-ZZ
nCyc = 1000
ElseIf iType1To4 = 3 Then
c1 = 703: c2 = Columns.Count ' AAA-End
nCyc = 100
ElseIf iType1To4 = 4 Then
c1 = 1: c2 = Columns.Count ' ALL (A-End 16 384 columns)
nCyc = 100
Else
Err.Raise xlErrNA
End If
ReDim arrNum(c2 - c1): i = -1
ReDim arrLtr(UBound(arrNum))
For c = c1 To c2
i = i + 1
arrNum(i) = c
arrLtr(i) = ByAddress_Left(c)
Next c
If Len(txCDMR) Then
Debug.Print iType1To4, txCDMR, FuncTest(txCDMR, nCyc, arrNum, arrLtr)
Tester = True: Exit Function
End If
arr = Array("b", "d", "m", "r")
ReDim arrTime(1 To UBound(arr) + 2, 1 To 1)
arrTime(1, 1) = nCyc
For i = 0 To UBound(arr)
c = FuncTest(arr(i), nCyc, arrNum, arrLtr)
If c = -1 Then Exit Function Else arrTime(i + 2, 1) = c
Next i
shComp.Cells(3, iType1To4 + 1).Resize(UBound(arrTime), 1).Value2 = arrTime
Tester = True
End Function
'====================================================================================================
'====================================================================================================
'====================================================================================================
'====================================================================================================
Function FuncTest(ByVal txCDMR$, nCycles&, arrNum() As Long, arrLtr() As String) As Long
Dim tx$, t!, cyc&, i&
Dim fBed As Boolean, fDo As Boolean, fMS As Boolean, fRec As Boolean
tx = LCase$(txCDMR)
If tx = "b" Then fBed = True: txCDMR = "BedVit": GoTo nx
If tx = "d" Then fDo = True: txCDMR = "iDo": GoTo nx
If tx = "m" Then fMS = True: txCDMR = "MSdoc": GoTo nx
If tx = "r" Then fRec = True: txCDMR = "Recur": GoTo nx
Err.Raise xlErrNA
nx: t = Timer
For cyc = 1 To nCycles
For i = 0 To UBound(arrNum)
If fBed Then
tx = BedVit(arrNum(i))
ElseIf fDo Then
tx = iDo(arrNum(i))
ElseIf fMS Then
tx = MSdoc(arrNum(i))
ElseIf fRec Then
tx = Recur(arrNum(i))
End If
If tx <> arrLtr(i) Then MsgBox tx & "<>" & arrLtr(i), vbCritical, txCDMR: FuncTest = -1: Exit Function
Next i
Next cyc
FuncTest = 1000 * (Timer - t)
End Function
'====================================================================================================
'====================================================================================================
Function BedVit(nCol&) As String
Dim A1(0 To 5) As Byte
Dim i&, col1&, col2&, col3&
i = 0: col3 = nCol \ 676 '(26 * 26)
If col3 > 0 Then A1(i * 2) = col3 + 64: i = i + 1
col2 = (nCol / 26) - col3 * 26
If col2 > 0 Then A1(i * 2) = col2 + 64: i = i + 1
col1 = nCol Mod 26
A1(i * 2) = col1 + 64
BedVit = A1
End Function
'----------------------------------------------------------------------------------------------------
Function ColNumToLtr(ByVal nCol&) As String ' не дала выигрыша и выбывает
If nCol < 703 Then
ColNumToLtr = Recur(nCol)
Else
ColNumToLtr = iDo(nCol)
End If
End Function
'----------------------------------------------------------------------------------------------------
Function iDo(ByVal nCol&) As String
Dim s$, n&, c&
n = nCol
Do
c = ((n - 1) Mod 26)
s = Chr$(c + 65) & s
n = (n - c) \ 26
Loop While n > 0
iDo = s
End Function
'----------------------------------------------------------------------------------------------------
' https://docs.microsoft.com/ru-ru/office/troubleshoot/excel/convert-excel-column-numbers
Function MSdoc(ByVal nCol&) As String
Dim a&, b&
Do While nCol > 0
a = Int((nCol - 1) / 26)
b = (nCol - 1) Mod 26
MSdoc = Chr$(b + 65) & MSdoc
nCol = a
Loop
End Function
'----------------------------------------------------------------------------------------------------
Function Recur(ByVal nCol&) As String
Dim lAlpha&, lRemainder&
If nCol <= 26 Then Recur = Chr$(nCol + 64): Exit Function
lRemainder = nCol Mod 26
lAlpha = Int(nCol / 26)
If lRemainder = 0 Then lRemainder = 26: lAlpha = lAlpha - 1
Recur = Recur(lAlpha) & Chr$(lRemainder + 64)
End Function
'====================================================================================================
'====================================================================================================
Function ByAddress_Left(ByVal nCol&) As String ' выбывает из-за медлительности
Dim tx$
tx = Columns(nCol).Address(0, 0, xlA1)
ByAddress_Left = Left$(tx, InStr(tx, ":") - 1)
End Function
'====================================================================================================
Function ByAddress_Split(ByVal nCol&) As String ' выбывает из-за медлительности (медленнее, чем Left)
ByAddress_Split = Split(Columns(nCol).Address(0, 0, xlA1), ":")(0)
End Function
'====================================================================================================
'====================================================================================================
Sub t()
MsgBox Kaz(26)
End Sub
Function Kaz(ByVal col&) As String ' выбыл из-за некорректного преобразования
Do
Kaz = Chr$(64 + col Mod 26) & Kaz
col = col \ 26
Loop Until col = 0
End Function
'====================================================================================================
' https://overcoder.net/q/5750/%D1%84%D1%83%D0%BD%D0%BA%D1%86%D0%B8%D1%8F-%D0%B4%D0%BB%D1%8F-%D0%BF%D1%80%D0%B5%D0%BE%D0%B1%D1%80%D0%B0%D0%B7%D0%BE%D0%B2%D0%B0%D0%BD%D0%B8%D1%8F-%D0%BD%D0%BE%D0%BC%D0%B5%D1%80%D0%B0-%D1%81%D1%82%D0%BE%D0%BB%D0%B1%D1%86%D0%B0-%D0%B2-%D0%B1%D1%83%D0%BA%D0%B2%D1%83
Function OneTwoThree(ByVal nCol&) As String ' выбыл из-за некорректного преобразования
If nCol < 27 Then OneTwoThree = Chr$(64 + nCol): Exit Function 'A
If nCol < 677 Then OneTwoThree = Chr$(64 + Int(nCol / 26)) & Chr$(64 + nCol - (Int(nCol / 26) * 26)): Exit Function ' AA
OneTwoThree = Chr$(64 + Int(nCol / 676)) & Chr$(64 + Int(nCol - Int(nCol / 676) * 676) / 26) & Chr$(64 + nCol - (Int(nCol - Int(nCol / 676) * 676) / 26) * 26) ' AAA
End Function
'====================================================================================================
Public Function JanW(ByVal nCol&) As String ' выбыл из-за переполнения стэка
JanW = JanW(Int((nCol - 1) / 26)) & Chr$(((nCol - 1) Mod 26) + Asc("A"))
End Function
'====================================================================================================
Function Recur2(ByVal nCol&) As String ' выбыл из-за некорректного преобразования
Dim iAlpha&, iRemainder&
iAlpha = Int(nCol / 27)
iRemainder = nCol - (iAlpha * 26)
If iAlpha > 0 Then Recur2 = Chr$(iAlpha + 64)
If iRemainder > 0 Then Recur2 = Recur2 & Chr$(iRemainder + 64)
End Function
'====================================================================================================
Изменено: - 25.05.2021 11:20:24
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Юрий М, #1 строка кода 67 - о том, но я это уже оттестировал и оно самое медленное Прятал под спойлерами, чтобы оформить красиво и место не занимать попусту, а получается, что уже как минимум второй (DANIKOLA ещё) коды не смотрел
Изменено: - 25.05.2021 11:50:29
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 02.04.2015
Виталий
25.05.2021 11:52:02
Я показал методику. Хорошо, сделал все за тебя 1 млн. определений 3х букв столбца - 0,7 сек.
Код
Sub testC1toA1()
Dim t, x
t = Timer
For x = 1 To 1000000
C1toA1 (16000)
Next
Debug.Print "C1toA1 " & Timer - t
End Sub
Function C1toA1(col As Long) As String
Dim A1() As Byte, i As Long, col3 As Long, col2 As Long, col1 As Long
i = 0
col3 = col \ 676 '(26 * 26)
If col3 > 0 Then ReDim A1(0 To 5): A1(i * 2) = col3 + 64: i = i + 1
col2 = (col \ 26) - col3 * 26
If col2 > 0 Then
If i = 0 Then ReDim A1(0 To 3)
A1(i * 2) = col2 + 64
i = i + 1
End If
col1 = col Mod 26
If i = 0 Then ReDim A1(0 To 1)
A1(i * 2) = col1 + 64
C1toA1 = A1
End Function
«Бритва Оккама» или «Принцип Калашникова»?
Модератор
Сообщений: Регистрация: 14.09.2012
Контакты см. в профиле
25.05.2021 11:55:19
Я смотрел, но не увидел. А вообще количество спойлеров в твоих сообщениях впечатляет )
Option Explicit
Option Private Module
'====================================================================================================
Sub Checker()
Dim ltr$, res$, c&
For c = 1 To Columns.Count
ltr = Columns(c).Address(0, 0, xlA1)
ltr = Left$(ltr, InStr(ltr, ":") - 1)
res = BedVit(c)
If ltr <> res Then MsgBox "The Column #" & Format$(c, "#,##0") & " have letter(s) «" & ltr & "», but testFunc return «" & res & "»", vbCritical, "UnCorrect result": Exit Sub
Next c
MsgBox "SUCCESS", vbInformation
End Sub
'====================================================================================================
Function BedVit(nCol&) As String
Dim A1() As Byte
Dim i&, col3&, col2&, col1&
i = 0
col3 = nCol \ 676 '(26 * 26)
If col3 > 0 Then ReDim A1(0 To 5): A1(i * 2) = col3 + 64: i = i + 1
col2 = (nCol \ 26) - col3 * 26
If col2 > 0 Then
If i = 0 Then ReDim A1(0 To 3)
A1(i * 2) = col2 + 64
i = i + 1
End If
col1 = nCol Mod 26
If i = 0 Then ReDim A1(0 To 1)
A1(i * 2) = col1 + 64
BedVit = A1
End Function
'====================================================================================================
Цитата
Юрий М: количество спойлеров в твоих сообщениях впечатляет
удобно - можно прятать длинные тексты, картинки и коды Все бы так делали, меньше скролить пришлось бы За мастер-класс, кстати, спасибо Виктору - это он меня как-то научил
Изменено: - 25.05.2021 12:23:15
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 02.04.2015
Виталий
25.05.2021 15:47:00
Немного подправил, но умещаюсь в 1 сек на 1 млн определений 3х букв столбца
Код
Sub testC1toA1()
Dim t, x
t = Timer
For x = 1 To 1000000
C1toA1 (16000)
Next
Debug.Print "C1toA1 " & Timer - t
End Sub
Function C1toA1(col As Long) As String
Dim A1() As Byte, i As Long, col3 As Long, col2 As Long, col1 As Long, col4 As Long, cQUO As Long, cMOD As Long
i = 0
cQUO = (col - 26) \ 676 '(26 * 26)
cQUO2 = (col - 26) \ 26
cMOD = col Mod 26
cMOD2 = cQUO2 Mod 26
If cMOD = 0 And cMOD2 = 0 Then
If cQUO > 0 Then col3 = cQUO - 1 Else col3 = cQUO
Else
col3 = cQUO
End If
If col3 > 0 Then ReDim A1(0 To 5): A1(i * 2) = col3 + 64: i = i + 1
If cMOD = 0 Then col2 = (col \ 26) - col3 * 26 - 1 Else col2 = (col \ 26) - col3 * 26
If col2 > 0 Then
If i = 0 Then ReDim A1(0 To 3)
A1(i * 2) = col2 + 64
i = i + 1
End If
If cMOD = 0 Then col1 = 26 Else col1 = cMOD
If i = 0 Then ReDim A1(0 To 1)
A1(i * 2) = col1 + 64
C1toA1 = A1
End Function
«Бритва Оккама» или «Принцип Калашникова»?
Пользователь
Сообщений: Регистрация: 02.04.2015
Виталий
25.05.2021 15:51:48
Думаю можно еще оптимизнуть, но нет времени, может кто-то из спецов доведет до ума
bedvit, достойно и на 3ёх буквах, как и в цикле по всем номерам столбцов (потому что большинство столбцов именно трёхбуквенные) безусловный лидер, но в целом это последнее место среди участников, тем более, что нормальные данные редко в столбцах после 702го (703 = AAA) располагаются
Скрин
Очень хорошо — спасибо за отличный вариант!
Если даже совместить (в лоб) Recur - для столбцов 1-702 и BedVit'a — для 703 и далее, то будет хуже (Combine), чем простая рекурсия за счёт дополнительных проверок
Сравнение
Коды
Код
Option Explicit
Option Private Module
'====================================================================================================
Sub Start()
Dim i&
'Tester 1, "kaz": Exit Sub
shComp.Range("B3:E7").ClearContents
For i = 1 To 4
If Not Tester(i) Then Exit Sub
Next i
End Sub
'====================================================================================================
Function Tester(iType1To4&, Optional txCDMR$) As Boolean
Dim arr(), arrTime() As Long, arrNum() As Long, arrLtr() As String
Dim nCyc&, c&, c1&, c2&, i&
If iType1To4 = 1 Then
c1 = 1: c2 = 26: ' A-Z
nCyc = 100000
ElseIf iType1To4 = 2 Then
c1 = 27: c2 = 702: ' AA-ZZ
nCyc = 1000
ElseIf iType1To4 = 3 Then
c1 = 703: c2 = Columns.Count ' AAA-End
nCyc = 100
ElseIf iType1To4 = 4 Then
c1 = 1: c2 = Columns.Count ' ALL (A-End 16 384 columns)
nCyc = 100
Else
Err.Raise xlErrNA
End If
ReDim arrNum(c2 - c1): i = -1
ReDim arrLtr(UBound(arrNum))
For c = c1 To c2
i = i + 1
arrNum(i) = c
arrLtr(i) = ByAddress_Left(c)
Next c
If Len(txCDMR) Then
Debug.Print iType1To4, txCDMR, FuncTest(txCDMR, nCyc, arrNum, arrLtr)
Tester = True: Exit Function
End If
arr = Array("c", "r", "b", "d", "m")
ReDim arrTime(1 To UBound(arr) + 2, 1 To 1)
arrTime(1, 1) = nCyc
For i = 0 To UBound(arr)
c = FuncTest(arr(i), nCyc, arrNum, arrLtr)
If c = -1 Then Exit Function Else arrTime(i + 2, 1) = c
Next i
shComp.Cells(3, iType1To4 + 1).Resize(UBound(arrTime), 1).Value2 = arrTime
Tester = True
End Function
'====================================================================================================
Function FuncTest(ByVal txCDMR$, nCycles&, arrNum() As Long, arrLtr() As String) As Long
Dim tx$, t!, cyc&, i&
Dim fCombine As Boolean, fBed As Boolean, fDo As Boolean, fMS As Boolean, fRec As Boolean
tx = LCase$(txCDMR)
If tx = "c" Then fCombine = True: txCDMR = "Combine": GoTo nx1
If tx = "r" Then fRec = True: txCDMR = "Recur": GoTo nx1
If tx = "b" Then fBed = True: txCDMR = "BedVit": GoTo nx1
If tx = "d" Then fDo = True: txCDMR = "iDo": GoTo nx1
If tx = "m" Then fMS = True: txCDMR = "MSdoc": GoTo nx1
Err.Raise xlErrNA
nx1: t = Timer
For cyc = 1 To nCycles
For i = 0 To UBound(arrNum)
If fCombine Then tx = Combine(arrNum(i)): GoTo nx2
If fRec Then tx = Recur(arrNum(i)): GoTo nx2
If fBed Then tx = BedVit(arrNum(i)): GoTo nx2
If fDo Then tx = iDo(arrNum(i)): GoTo nx2
If fMS Then tx = MSdoc(arrNum(i)): GoTo nx2
If tx <> arrLtr(i) Then MsgBox tx & "<>" & arrLtr(i), vbCritical, txCDMR: FuncTest = -1: Exit Function
nx2: Next i
Next cyc
FuncTest = 1000 * (Timer - t)
End Function
'====================================================================================================
Sub Checker()
Dim ltr$, res$, c&
For c = 1 To Columns.Count
ltr = Columns(c).Address(0, 0, xlA1)
ltr = Left$(ltr, InStr(ltr, ":") - 1)
res = BedVit(c)
If ltr <> res Then MsgBox "The Column #" & Format$(c, "#,##0") & " have letter(s) «" & ltr & "», but testFunc return «" & res & "»", vbCritical, "UnCorrect result": Exit Sub
Next c
MsgBox "SUCCESS", vbInformation
End Sub
'====================================================================================================
'====================================================================================================
Function Combine(ByVal nCol&) As String
If nCol < 703 Then
Combine = Recur(nCol)
Else
Combine = BedVit(nCol)
End If
End Function
'====================================================================================================
Function BedVit(nCol&) As String
Dim A1() As Byte
Dim i&, col3&, col2&, col1&, col4&, cQUO&, cQUO2&, cMOD&, cMOD2&
i = 0
cQUO = (nCol - 26) \ 676 '(26 * 26)
cQUO2 = (nCol - 26) \ 26
cMOD = nCol Mod 26
cMOD2 = cQUO2 Mod 26
If cMOD = 0 And cMOD2 = 0 Then
If cQUO > 0 Then col3 = cQUO - 1 Else col3 = cQUO
Else
col3 = cQUO
End If
If col3 > 0 Then ReDim A1(0 To 5): A1(i * 2) = col3 + 64: i = i + 1
If cMOD = 0 Then col2 = (nCol \ 26) - col3 * 26 - 1 Else col2 = (nCol \ 26) - col3 * 26
If col2 > 0 Then
If i = 0 Then ReDim A1(0 To 3)
A1(i * 2) = col2 + 64
i = i + 1
End If
If cMOD = 0 Then col1 = 26 Else col1 = cMOD
If i = 0 Then ReDim A1(0 To 1)
A1(i * 2) = col1 + 64
BedVit = A1
End Function
'----------------------------------------------------------------------------------------------------
Function iDo(ByVal nCol&) As String
Dim s$, n&, c&
n = nCol
Do
c = ((n - 1) Mod 26)
s = Chr$(c + 65) & s
n = (n - c) \ 26
Loop While n > 0
iDo = s
End Function
'----------------------------------------------------------------------------------------------------
' https://docs.microsoft.com/ru-ru/office/troubleshoot/excel/convert-excel-column-numbers
Function MSdoc(ByVal nCol&) As String
Dim a&, b&
Do While nCol > 0
a = Int((nCol - 1) / 26)
b = (nCol - 1) Mod 26
MSdoc = Chr$(b + 65) & MSdoc
nCol = a
Loop
End Function
'----------------------------------------------------------------------------------------------------
Function Recur(ByVal nCol&) As String
Dim lAlpha&, lRemainder&
If nCol <= 26 Then Recur = Chr$(nCol + 64): Exit Function
lRemainder = nCol Mod 26
lAlpha = Int(nCol / 26)
If lRemainder = 0 Then lRemainder = 26: lAlpha = lAlpha - 1
Recur = Recur(lAlpha) & Chr$(lRemainder + 64)
End Function
'====================================================================================================
'====================================================================================================
Function iLeft(ByVal nCol&) As String
Dim tx$
If nCol > 702 Then iLeft = Left$(Columns(nCol).Address(0, 0, xlA1), 3): Exit Function
If nCol > 26 Then iLeft = Left$(Columns(nCol).Address(0, 0, xlA1), 2): Exit Function
iLeft = Left$(Columns(nCol).Address(0, 0, xlA1), 1)
End Function
'----------------------------------------------------------------------------------------------------
Function ByAddress_Left(ByVal nCol&) As String ' выбывает из-за медлительности
Dim tx$
tx = Columns(nCol).Address(0, 0, xlA1)
ByAddress_Left = Left$(tx, InStr(tx, ":") - 1)
End Function
'====================================================================================================
Function ByAddress_Split(ByVal nCol&) As String ' выбывает из-за медлительности (медленнее, чем Left)
ByAddress_Split = Split(Columns(nCol).Address(0, 0, xlA1), ":")(0)
End Function
'====================================================================================================
'====================================================================================================
Sub tKaz()
MsgBox Kaz(26)
End Sub
Function Kaz(ByVal col&) As String ' выбыл из-за некорректного преобразования
Do
Kaz = Chr$(64 + col Mod 26) & Kaz
col = col \ 26
Loop Until col = 0
End Function
'====================================================================================================
' https://overcoder.net/q/5750/%D1%84%D1%83%D0%BD%D0%BA%D1%86%D0%B8%D1%8F-%D0%B4%D0%BB%D1%8F-%D0%BF%D1%80%D0%B5%D0%BE%D0%B1%D1%80%D0%B0%D0%B7%D0%BE%D0%B2%D0%B0%D0%BD%D0%B8%D1%8F-%D0%BD%D0%BE%D0%BC%D0%B5%D1%80%D0%B0-%D1%81%D1%82%D0%BE%D0%BB%D0%B1%D1%86%D0%B0-%D0%B2-%D0%B1%D1%83%D0%BA%D0%B2%D1%83
Function OneTwoThree(ByVal nCol&) As String ' выбыл из-за некорректного преобразования
If nCol < 27 Then OneTwoThree = Chr$(64 + nCol): Exit Function 'A
If nCol < 677 Then OneTwoThree = Chr$(64 + Int(nCol / 26)) & Chr$(64 + nCol - (Int(nCol / 26) * 26)): Exit Function ' AA
OneTwoThree = Chr$(64 + Int(nCol / 676)) & Chr$(64 + Int(nCol - Int(nCol / 676) * 676) / 26) & Chr$(64 + nCol - (Int(nCol - Int(nCol / 676) * 676) / 26) * 26) ' AAA
End Function
'====================================================================================================
Public Function JanW(ByVal nCol&) As String ' выбыл из-за переполнения стэка
JanW = JanW(Int((nCol - 1) / 26)) & Chr$(((nCol - 1) Mod 26) + Asc("A"))
End Function
'====================================================================================================
Function Recur2(ByVal nCol&) As String ' выбыл из-за некорректного преобразования
Dim iAlpha&, iRemainder&
iAlpha = Int(nCol / 27)
iRemainder = nCol - (iAlpha * 26)
If iAlpha > 0 Then Recur2 = Chr$(iAlpha + 64)
If iRemainder > 0 Then Recur2 = Recur2 & Chr$(iRemainder + 64)
End Function
'====================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 02.04.2015
Виталий
26.05.2021 10:22:58
Немного ускорил, протестируй пожалуйста
Код
Function C1toA1(col As Long) As Byte() 'номер столбца в букву
Dim A1() As Byte, cQUO As Long, cMOD As Long, cQUO2 As Long, cMOD2 As Long
If col <= 26 Then ' одна буква
ReDim A1(0 To 1)
A1(0) = col + 64
ElseIf col <= 702 Then ' 2 буквы
ReDim A1(0 To 3)
cQUO = col \ 26
cMOD = col Mod 26
If cMOD = 0 Then cQUO = cQUO - 1: cMOD = 26
A1(0) = cQUO + 64
A1(2) = cMOD + 64
Else ' 3 буквы
ReDim A1(0 To 5)
cQUO = col \ 26
cMOD = col Mod 26
cQUO2 = (col - 26) \ 676 '(26 * 26)
cMOD2 = (col - 26) Mod 676
If cMOD2 = 0 Then cQUO2 = cQUO2 - 1
If cMOD = 0 Then cQUO = cQUO - 1: cMOD = 26
A1(0) = cQUO2 + 64
A1(2) = (cQUO - cQUO2 * 26) + 64
A1(4) = cMOD + 64
End If
C1toA1 = A1
End Function
Option Explicit
Option Private Module
'====================================================================================================
Sub Start()
Dim i&
'Tester 1, "kaz": Exit Sub
shComp.Range("B3:E8").ClearContents
For i = 1 To 4
If Not Tester(i) Then Exit Sub
Next i
End Sub
'====================================================================================================
Function Tester(iType1To4&, Optional txCDMR$) As Boolean
Dim arr(), arrTime() As Long, arrNum() As Long, arrLtr() As String
Dim nCyc&, c&, c1&, c2&, i&
If iType1To4 = 1 Then
c1 = 1: c2 = 26: ' A-Z
nCyc = 100000
ElseIf iType1To4 = 2 Then
c1 = 27: c2 = 702: ' AA-ZZ
nCyc = 1000
ElseIf iType1To4 = 3 Then
c1 = 703: c2 = Columns.Count ' AAA-End
nCyc = 100
ElseIf iType1To4 = 4 Then
c1 = 1: c2 = Columns.Count ' ALL (A-End 16 384 columns)
nCyc = 100
Else
Err.Raise xlErrNA
End If
ReDim arrNum(c2 - c1): i = -1
ReDim arrLtr(UBound(arrNum))
For c = c1 To c2
i = i + 1
arrNum(i) = c
arrLtr(i) = ByAddress_Left(c)
Next c
If Len(txCDMR) Then
Debug.Print iType1To4, txCDMR, FuncTest(txCDMR, nCyc, arrNum, arrLtr)
Tester = True: Exit Function
End If
arr = Array("c", "r", "b")
ReDim arrTime(1 To UBound(arr) + 2, 1 To 1)
arrTime(1, 1) = nCyc
For i = 0 To UBound(arr)
c = FuncTest(arr(i), nCyc, arrNum, arrLtr)
If c = -1 Then Exit Function Else arrTime(i + 2, 1) = c
Next i
shComp.Cells(3, iType1To4 + 1).Resize(UBound(arrTime), 1).Value2 = arrTime
Tester = True
End Function
'====================================================================================================
Function FuncTest(ByVal txCDMR$, nCycles&, arrNum() As Long, arrLtr() As String) As Long
Dim tx$, t!, cyc&, i&
Dim fCombine As Boolean, fBed As Boolean, fDo As Boolean, fMS As Boolean, fRec As Boolean
tx = LCase$(txCDMR)
If tx = "c" Then fCombine = True: txCDMR = "Combine": GoTo nx1
If tx = "r" Then fRec = True: txCDMR = "Recur": GoTo nx1
If tx = "b" Then fBed = True: txCDMR = "BedVit": GoTo nx1
If tx = "d" Then fDo = True: txCDMR = "iDo": GoTo nx1
If tx = "m" Then fMS = True: txCDMR = "MSdoc": GoTo nx1
Err.Raise xlErrNA
nx1: t = Timer
For cyc = 1 To nCycles
For i = 0 To UBound(arrNum)
If fCombine Then tx = Combine(arrNum(i)): GoTo nx2
If fRec Then tx = Recur(arrNum(i)): GoTo nx2
If fBed Then tx = BedVit(arrNum(i)): GoTo nx2
If fDo Then tx = iDo(arrNum(i)): GoTo nx2
If fMS Then tx = MSdoc(arrNum(i)): GoTo nx2
If tx <> arrLtr(i) Then MsgBox tx & "<>" & arrLtr(i), vbCritical, txCDMR: FuncTest = -1: Exit Function
nx2: Next i
Next cyc
FuncTest = 1000 * (Timer - t)
End Function
'====================================================================================================
Sub Checker()
Dim ltr$, res$, c&
For c = 1 To Columns.Count
ltr = Columns(c).Address(0, 0, xlA1)
ltr = Left$(ltr, InStr(ltr, ":") - 1)
res = BedVit(c)
If ltr <> res Then MsgBox "The Column #" & Format$(c, "#,##0") & " have letter(s) «" & ltr & "», but testFunc return «" & res & "»", vbCritical, "UnCorrect result": Exit Sub
Next c
MsgBox "SUCCESS", vbInformation
End Sub
'====================================================================================================
'====================================================================================================
Function Combine(ByVal nCol&) As String
If nCol < 703 Then
Combine = Recur(nCol)
Else
Combine = BedVit(nCol)
End If
End Function
'----------------------------------------------------------------------------------------------------
Function Recur(ByVal nCol&) As String
Dim lAlpha&, lRemainder&
If nCol <= 26 Then Recur = Chr$(nCol + 64): Exit Function
lRemainder = nCol Mod 26
lAlpha = Int(nCol / 26)
If lRemainder = 0 Then lRemainder = 26: lAlpha = lAlpha - 1
Recur = Recur(lAlpha) & Chr$(lRemainder + 64)
End Function
'----------------------------------------------------------------------------------------------------
Function BedVit(col As Long) As Byte()
Dim A1() As Byte, cQUO As Long, cMOD As Long, cQUO2 As Long, cMOD2 As Long
If col <= 26 Then ' <= 26 или < 27 — не влияет на скорость
ReDim A1(0 To 1)
A1(0) = col + 64
ElseIf col <= 702 Then '<= 702 или < 703 — не влияет на скорость
ReDim A1(0 To 3)
cQUO = col \ 26
cMOD = col Mod 26
If cMOD = 0 Then cQUO = cQUO - 1: cMOD = 26
A1(0) = cQUO + 64
A1(2) = cMOD + 64
Else
ReDim A1(0 To 5)
cQUO = col \ 26
cMOD = col Mod 26
cQUO2 = (col - 26) \ 676 '(26 * 26)
cMOD2 = (col - 26) Mod 676
If cMOD2 = 0 Then cQUO2 = cQUO2 - 1
If cMOD = 0 Then cQUO = cQUO - 1: cMOD = 26
A1(0) = cQUO2 + 64
A1(2) = (cQUO - cQUO2 * 26) + 64
A1(4) = cMOD + 64
End If
BedVit = A1
End Function
'====================================================================================================
'====================================================================================================
Function iDo(ByVal nCol&) As String
Dim s$, n&, c&
n = nCol
Do
c = ((n - 1) Mod 26)
s = Chr$(c + 65) & s
n = (n - c) \ 26
Loop While n > 0
iDo = s
End Function
'----------------------------------------------------------------------------------------------------
' https://docs.microsoft.com/ru-ru/office/troubleshoot/excel/convert-excel-column-numbers
Function MSdoc(ByVal nCol&) As String
Dim a&, b&
Do While nCol > 0
a = Int((nCol - 1) / 26)
b = (nCol - 1) Mod 26
MSdoc = Chr$(b + 65) & MSdoc
nCol = a
Loop
End Function
'====================================================================================================
'====================================================================================================
Function iLeft(ByVal nCol&) As String
Dim tx$
If nCol > 702 Then iLeft = Left$(Columns(nCol).Address(0, 0, xlA1), 3): Exit Function
If nCol > 26 Then iLeft = Left$(Columns(nCol).Address(0, 0, xlA1), 2): Exit Function
iLeft = Left$(Columns(nCol).Address(0, 0, xlA1), 1)
End Function
'----------------------------------------------------------------------------------------------------
Function ByAddress_Left(ByVal nCol&) As String ' выбывает из-за медлительности
Dim tx$
tx = Columns(nCol).Address(0, 0, xlA1)
ByAddress_Left = Left$(tx, InStr(tx, ":") - 1)
End Function
'====================================================================================================
Function ByAddress_Split(ByVal nCol&) As String ' выбывает из-за медлительности (медленнее, чем Left)
ByAddress_Split = Split(Columns(nCol).Address(0, 0, xlA1), ":")(0)
End Function
'====================================================================================================
'====================================================================================================
Sub tKaz()
MsgBox Kaz(26)
End Sub
Function Kaz(ByVal col&) As String ' выбыл из-за некорректного преобразования
Do
Kaz = Chr$(64 + col Mod 26) & Kaz
col = col \ 26
Loop Until col = 0
End Function
'====================================================================================================
' https://overcoder.net/q/5750/%D1%84%D1%83%D0%BD%D0%BA%D1%86%D0%B8%D1%8F-%D0%B4%D0%BB%D1%8F-%D0%BF%D1%80%D0%B5%D0%BE%D0%B1%D1%80%D0%B0%D0%B7%D0%BE%D0%B2%D0%B0%D0%BD%D0%B8%D1%8F-%D0%BD%D0%BE%D0%BC%D0%B5%D1%80%D0%B0-%D1%81%D1%82%D0%BE%D0%BB%D0%B1%D1%86%D0%B0-%D0%B2-%D0%B1%D1%83%D0%BA%D0%B2%D1%83
Function OneTwoThree(ByVal nCol&) As String ' выбыл из-за некорректного преобразования
If nCol < 27 Then OneTwoThree = Chr$(64 + nCol): Exit Function 'A
If nCol < 677 Then OneTwoThree = Chr$(64 + Int(nCol / 26)) & Chr$(64 + nCol - (Int(nCol / 26) * 26)): Exit Function ' AA
OneTwoThree = Chr$(64 + Int(nCol / 676)) & Chr$(64 + Int(nCol - Int(nCol / 676) * 676) / 26) & Chr$(64 + nCol - (Int(nCol - Int(nCol / 676) * 676) / 26) * 26) ' AAA
End Function
'====================================================================================================
Public Function JanW(ByVal nCol&) As String ' выбыл из-за переполнения стэка
JanW = JanW(Int((nCol - 1) / 26)) & Chr$(((nCol - 1) Mod 26) + Asc("A"))
End Function
'====================================================================================================
Function Recur2(ByVal nCol&) As String ' выбыл из-за некорректного преобразования
Dim iAlpha&, iRemainder&
iAlpha = Int(nCol / 27)
iRemainder = nCol - (iAlpha * 26)
If iAlpha > 0 Then Recur2 = Chr$(iAlpha + 64)
If iRemainder > 0 Then Recur2 = Recur2 & Chr$(iRemainder + 64)
End Function
'====================================================================================================
ща ускорю — есть идея
Ну вот - теперь топ (хотя проигрыш на первых двух всё-равно есть и это плохо)
Сравнение
Коды
Код
Option Explicit
Option Private Module
'====================================================================================================
Sub Start()
Dim i&
'Tester 1, "kaz": Exit Sub
shComp.Range("B3:E8").ClearContents
For i = 1 To 4
If Not Tester(i) Then Exit Sub
Next i
End Sub
'====================================================================================================
Function Tester(iType1To4&, Optional txCDMR$) As Boolean
Dim arr(), arrTime() As Long, arrNum() As Long, arrLtr() As String
Dim nCyc&, c&, c1&, c2&, i&
If iType1To4 = 1 Then
c1 = 1: c2 = 26: ' A-Z
nCyc = 100000
ElseIf iType1To4 = 2 Then
c1 = 27: c2 = 702: ' AA-ZZ
nCyc = 1000
ElseIf iType1To4 = 3 Then
c1 = 703: c2 = Columns.Count ' AAA-End
nCyc = 100
ElseIf iType1To4 = 4 Then
c1 = 1: c2 = Columns.Count ' ALL (A-End 16 384 columns)
nCyc = 100
Else
Err.Raise xlErrNA
End If
ReDim arrNum(c2 - c1): i = -1
ReDim arrLtr(UBound(arrNum))
For c = c1 To c2
i = i + 1
arrNum(i) = c
arrLtr(i) = ByAddress_Left(c)
Next c
If Len(txCDMR) Then
Debug.Print iType1To4, txCDMR, FuncTest(txCDMR, nCyc, arrNum, arrLtr)
Tester = True: Exit Function
End If
arr = Array("c", "r", "b")
ReDim arrTime(1 To UBound(arr) + 2, 1 To 1)
arrTime(1, 1) = nCyc
For i = 0 To UBound(arr)
c = FuncTest(arr(i), nCyc, arrNum, arrLtr)
If c = -1 Then Exit Function Else arrTime(i + 2, 1) = c
Next i
shComp.Cells(3, iType1To4 + 1).Resize(UBound(arrTime), 1).Value2 = arrTime
Tester = True
End Function
'====================================================================================================
Function FuncTest(ByVal txCDMR$, nCycles&, arrNum() As Long, arrLtr() As String) As Long
Dim tx$, t!, cyc&, i&
Dim fCombine As Boolean, fBed As Boolean, fDo As Boolean, fMS As Boolean, fRec As Boolean
tx = LCase$(txCDMR)
If tx = "c" Then fCombine = True: txCDMR = "Combine": GoTo nx1
If tx = "r" Then fRec = True: txCDMR = "Recur": GoTo nx1
If tx = "b" Then fBed = True: txCDMR = "BedVit": GoTo nx1
If tx = "d" Then fDo = True: txCDMR = "iDo": GoTo nx1
If tx = "m" Then fMS = True: txCDMR = "MSdoc": GoTo nx1
Err.Raise xlErrNA
nx1: t = Timer
For cyc = 1 To nCycles
For i = 0 To UBound(arrNum)
If fCombine Then tx = Combine(arrNum(i)): GoTo nx2
If fRec Then tx = Recur(arrNum(i)): GoTo nx2
If fBed Then tx = BedVit(arrNum(i)): GoTo nx2
If fDo Then tx = iDo(arrNum(i)): GoTo nx2
If fMS Then tx = MSdoc(arrNum(i)): GoTo nx2
If tx <> arrLtr(i) Then MsgBox tx & "<>" & arrLtr(i), vbCritical, txCDMR: FuncTest = -1: Exit Function
nx2: Next i
Next cyc
FuncTest = 1000 * (Timer - t)
End Function
'====================================================================================================
Sub Checker()
Dim ltr$, res$, c&
For c = 1 To Columns.Count
ltr = Columns(c).Address(0, 0, xlA1)
ltr = Left$(ltr, InStr(ltr, ":") - 1)
res = BedVit(c)
If ltr <> res Then MsgBox "The Column #" & Format$(c, "#,##0") & " have letter(s) «" & ltr & "», but testFunc return «" & res & "»", vbCritical, "UnCorrect result": Exit Sub
Next c
MsgBox "SUCCESS", vbInformation
End Sub
'====================================================================================================
'====================================================================================================
Function Combine(ByVal nCol&) As String
If nCol < 703 Then
Combine = Recur(nCol)
Else
Combine = BedVit(nCol)
End If
End Function
'----------------------------------------------------------------------------------------------------
Function Recur(ByVal nCol&) As String
Dim lAlpha&, lRemainder&
If nCol <= 26 Then Recur = Chr$(nCol + 64): Exit Function
lRemainder = nCol Mod 26
lAlpha = Int(nCol / 26)
If lRemainder = 0 Then lRemainder = 26: lAlpha = lAlpha - 1
Recur = Recur(lAlpha) & Chr$(lRemainder + 64)
End Function
'----------------------------------------------------------------------------------------------------
Function BedVit(nCol&) As String
Dim A() As Byte
Dim cQUO&, cQUO2&, cMOD&, cMOD2&
If nCol <= 26 Then BedVit = Chr$(nCol + 64): Exit Function
If nCol <= 702 Then '<= 702 или < 703 — не влияет на скорость
ReDim A(3) As Byte
cQUO = nCol \ 26
cMOD = nCol Mod 26
If cMOD = 0 Then cQUO = cQUO - 1: cMOD = 26
A(0) = cQUO + 64
A(2) = cMOD + 64
Else
ReDim A(5) As Byte
cQUO = nCol \ 26
cMOD = nCol Mod 26
cQUO2 = (nCol - 26) \ 676 '(26 * 26)
cMOD2 = (nCol - 26) Mod 676
If cMOD2 = 0 Then cQUO2 = cQUO2 - 1
If cMOD = 0 Then cQUO = cQUO - 1: cMOD = 26
A(0) = cQUO2 + 64
A(2) = (cQUO - cQUO2 * 26) + 64
A(4) = cMOD + 64
End If
BedVit = A
End Function
'====================================================================================================
'====================================================================================================
Function iDo(ByVal nCol&) As String
Dim s$, n&, c&
n = nCol
Do
c = ((n - 1) Mod 26)
s = Chr$(c + 65) & s
n = (n - c) \ 26
Loop While n > 0
iDo = s
End Function
'----------------------------------------------------------------------------------------------------
' https://docs.microsoft.com/ru-ru/office/troubleshoot/excel/convert-excel-column-numbers
Function MSdoc(ByVal nCol&) As String
Dim A&, b&
Do While nCol > 0
A = Int((nCol - 1) / 26)
b = (nCol - 1) Mod 26
MSdoc = Chr$(b + 65) & MSdoc
nCol = A
Loop
End Function
'====================================================================================================
'====================================================================================================
Function iLeft(ByVal nCol&) As String
Dim tx$
If nCol > 702 Then iLeft = Left$(Columns(nCol).Address(0, 0, xlA1), 3): Exit Function
If nCol > 26 Then iLeft = Left$(Columns(nCol).Address(0, 0, xlA1), 2): Exit Function
iLeft = Left$(Columns(nCol).Address(0, 0, xlA1), 1)
End Function
'----------------------------------------------------------------------------------------------------
Function ByAddress_Left(ByVal nCol&) As String ' выбывает из-за медлительности
Dim tx$
tx = Columns(nCol).Address(0, 0, xlA1)
ByAddress_Left = Left$(tx, InStr(tx, ":") - 1)
End Function
'====================================================================================================
Function ByAddress_Split(ByVal nCol&) As String ' выбывает из-за медлительности (медленнее, чем Left)
ByAddress_Split = Split(Columns(nCol).Address(0, 0, xlA1), ":")(0)
End Function
'====================================================================================================
'====================================================================================================
Sub tKaz()
MsgBox Kaz(26)
End Sub
Function Kaz(ByVal col&) As String ' выбыл из-за некорректного преобразования
Do
Kaz = Chr$(64 + col Mod 26) & Kaz
col = col \ 26
Loop Until col = 0
End Function
'====================================================================================================
' https://overcoder.net/q/5750/%D1%84%D1%83%D0%BD%D0%BA%D1%86%D0%B8%D1%8F-%D0%B4%D0%BB%D1%8F-%D0%BF%D1%80%D0%B5%D0%BE%D0%B1%D1%80%D0%B0%D0%B7%D0%BE%D0%B2%D0%B0%D0%BD%D0%B8%D1%8F-%D0%BD%D0%BE%D0%BC%D0%B5%D1%80%D0%B0-%D1%81%D1%82%D0%BE%D0%BB%D0%B1%D1%86%D0%B0-%D0%B2-%D0%B1%D1%83%D0%BA%D0%B2%D1%83
Function OneTwoThree(ByVal nCol&) As String ' выбыл из-за некорректного преобразования
If nCol < 27 Then OneTwoThree = Chr$(64 + nCol): Exit Function 'A
If nCol < 677 Then OneTwoThree = Chr$(64 + Int(nCol / 26)) & Chr$(64 + nCol - (Int(nCol / 26) * 26)): Exit Function ' AA
OneTwoThree = Chr$(64 + Int(nCol / 676)) & Chr$(64 + Int(nCol - Int(nCol / 676) * 676) / 26) & Chr$(64 + nCol - (Int(nCol - Int(nCol / 676) * 676) / 26) * 26) ' AAA
End Function
'====================================================================================================
Public Function JanW(ByVal nCol&) As String ' выбыл из-за переполнения стэка
JanW = JanW(Int((nCol - 1) / 26)) & Chr$(((nCol - 1) Mod 26) + Asc("A"))
End Function
'====================================================================================================
Function Recur2(ByVal nCol&) As String ' выбыл из-за некорректного преобразования
Dim iAlpha&, iRemainder&
iAlpha = Int(nCol / 27)
iRemainder = nCol - (iAlpha * 26)
If iAlpha > 0 Then Recur2 = Chr$(iAlpha + 64)
If iRemainder > 0 Then Recur2 = Recur2 & Chr$(iRemainder + 64)
End Function
'====================================================================================================
изменил возврат функции на String, чтобы ускорить получение буквы для однобуквенных столбцов
Минорные изменения и сравнение 2ух лидеров (BedVit and Recur)
Сравнение
Коды
Код
Option Explicit
Option Private Module
'====================================================================================================
Sub Start()
Dim i&
'Tester 1, "kaz": Exit Sub
shComp.Range("B3:E5").ClearContents
For i = 1 To 4
If Not Tester(i) Then Exit Sub
Next i
End Sub
'====================================================================================================
Function Tester(iType1To4&, Optional txCDMR$) As Boolean
Dim arr(), arrTime() As Long, arrNum() As Long, arrLtr() As String
Dim nCyc&, c&, c1&, c2&, i&
If iType1To4 = 1 Then
c1 = 1: c2 = 26: ' A-Z
nCyc = 100000
ElseIf iType1To4 = 2 Then
c1 = 27: c2 = 702: ' AA-ZZ
nCyc = 1000
ElseIf iType1To4 = 3 Then
c1 = 703: c2 = Columns.Count ' AAA-End
nCyc = 100
ElseIf iType1To4 = 4 Then
c1 = 1: c2 = Columns.Count ' ALL (A-End 16 384 columns)
nCyc = 100
Else
Err.Raise xlErrNA
End If
ReDim arrNum(c2 - c1): i = -1
ReDim arrLtr(UBound(arrNum))
For c = c1 To c2
i = i + 1
arrNum(i) = c
arrLtr(i) = ByAddress_Left(c)
Next c
If Len(txCDMR) Then
Debug.Print iType1To4, txCDMR, FuncTest(txCDMR, nCyc, arrNum, arrLtr)
Tester = True: Exit Function
End If
arr = Array("r", "b")
ReDim arrTime(1 To UBound(arr) + 2, 1 To 1)
arrTime(1, 1) = nCyc
For i = 0 To UBound(arr)
c = FuncTest(arr(i), nCyc, arrNum, arrLtr)
If c = -1 Then Exit Function Else arrTime(i + 2, 1) = c
Next i
shComp.Cells(3, iType1To4 + 1).Resize(UBound(arrTime), 1).Value2 = arrTime
Tester = True
End Function
'====================================================================================================
Function FuncTest(ByVal txCDMR$, nCycles&, arrNum() As Long, arrLtr() As String) As Long
Dim tx$, t!, cyc&, i&
Dim fCombine As Boolean, fBed As Boolean, fDo As Boolean, fMS As Boolean, fRec As Boolean
tx = LCase$(txCDMR)
If tx = "c" Then fCombine = True: txCDMR = "Combine": GoTo nx1
If tx = "r" Then fRec = True: txCDMR = "Recur": GoTo nx1
If tx = "b" Then fBed = True: txCDMR = "BedVit": GoTo nx1
If tx = "d" Then fDo = True: txCDMR = "iDo": GoTo nx1
If tx = "m" Then fMS = True: txCDMR = "MSdoc": GoTo nx1
Err.Raise xlErrNA
nx1: t = Timer
For cyc = 1 To nCycles
For i = 0 To UBound(arrNum)
If fCombine Then tx = Combine(arrNum(i)): GoTo nx2
If fRec Then tx = Recur(arrNum(i)): GoTo nx2
If fBed Then tx = BedVit(arrNum(i)): GoTo nx2
If fDo Then tx = iDo(arrNum(i)): GoTo nx2
If fMS Then tx = MSdoc(arrNum(i)): GoTo nx2
If tx <> arrLtr(i) Then MsgBox tx & "<>" & arrLtr(i), vbCritical, txCDMR: FuncTest = -1: Exit Function
nx2: Next i
Next cyc
FuncTest = 1000 * (Timer - t)
End Function
'====================================================================================================
Sub Checker()
Dim ltr$, res$, c&
For c = 1 To Columns.Count
ltr = Columns(c).Address(0, 0, xlA1)
ltr = Left$(ltr, InStr(ltr, ":") - 1)
res = BedVit(c)
If ltr <> res Then MsgBox "The Column #" & Format$(c, "#,##0") & " have letter(s) «" & ltr & "», but testFunc return «" & res & "»", vbCritical, "UnCorrect result": Exit Sub
Next c
MsgBox "SUCCESS", vbInformation
End Sub
'====================================================================================================
'====================================================================================================
Function Combine(ByVal nCol&) As String
If nCol < 703 Then
Combine = Recur(nCol)
Else
Combine = BedVit(nCol)
End If
End Function
'----------------------------------------------------------------------------------------------------
Function Recur(ByVal nCol&) As String
Dim lAlpha&, lRemainder&
If nCol <= 26 Then Recur = Chr$(nCol + 64): Exit Function
lRemainder = nCol Mod 26
If lRemainder = 0 Then
lRemainder = 26
lAlpha = lAlpha = Int(nCol / 26) - 1
Else
lAlpha = Int(nCol / 26)
End If
Recur = Recur(lAlpha) & Chr$(lRemainder + 64)
End Function
'----------------------------------------------------------------------------------------------------
Function BedVit(nCol&) As String
Dim A() As Byte
Dim cQUO&, cQUO2&, cMOD&, cMOD2&
If nCol <= 26 Then BedVit = Chr$(nCol + 64): Exit Function
If nCol <= 702 Then '<= 702 или < 703 — не влияет на скорость
ReDim A(3) As Byte
cQUO = nCol \ 26
cMOD = nCol Mod 26
If cMOD = 0 Then cQUO = cQUO - 1: cMOD = 26
A(0) = cQUO + 64
A(2) = cMOD + 64
Else
ReDim A(5) As Byte
cQUO = nCol \ 26
cMOD = nCol Mod 26
cQUO2 = (nCol - 26) \ 676 '(26 * 26)
cMOD2 = (nCol - 26) Mod 676
If cMOD2 = 0 Then cQUO2 = cQUO2 - 1
If cMOD = 0 Then cQUO = cQUO - 1: cMOD = 26
A(0) = cQUO2 + 64
A(2) = (cQUO - cQUO2 * 26) + 64
A(4) = cMOD + 64
End If
BedVit = A
End Function
'====================================================================================================
'====================================================================================================
Function iDo(ByVal nCol&) As String
Dim s$, n&, c&
n = nCol
Do
c = ((n - 1) Mod 26)
s = Chr$(c + 65) & s
n = (n - c) \ 26
Loop While n > 0
iDo = s
End Function
'----------------------------------------------------------------------------------------------------
' https://docs.microsoft.com/ru-ru/office/troubleshoot/excel/convert-excel-column-numbers
Function MSdoc(ByVal nCol&) As String
Dim A&, b&
Do While nCol > 0
A = Int((nCol - 1) / 26)
b = (nCol - 1) Mod 26
MSdoc = Chr$(b + 65) & MSdoc
nCol = A
Loop
End Function
'====================================================================================================
'====================================================================================================
Function iLeft(ByVal nCol&) As String
Dim tx$
If nCol > 702 Then iLeft = Left$(Columns(nCol).Address(0, 0, xlA1), 3): Exit Function
If nCol > 26 Then iLeft = Left$(Columns(nCol).Address(0, 0, xlA1), 2): Exit Function
iLeft = Left$(Columns(nCol).Address(0, 0, xlA1), 1)
End Function
'----------------------------------------------------------------------------------------------------
Function ByAddress_Left(ByVal nCol&) As String ' выбывает из-за медлительности
Dim tx$
tx = Columns(nCol).Address(0, 0, xlA1)
ByAddress_Left = Left$(tx, InStr(tx, ":") - 1)
End Function
'====================================================================================================
Function ByAddress_Split(ByVal nCol&) As String ' выбывает из-за медлительности (медленнее, чем Left)
ByAddress_Split = Split(Columns(nCol).Address(0, 0, xlA1), ":")(0)
End Function
'====================================================================================================
'====================================================================================================
Sub tKaz()
MsgBox Kaz(26)
End Sub
Function Kaz(ByVal col&) As String ' выбыл из-за некорректного преобразования
Do
Kaz = Chr$(64 + col Mod 26) & Kaz
col = col \ 26
Loop Until col = 0
End Function
'====================================================================================================
' https://overcoder.net/q/5750/%D1%84%D1%83%D0%BD%D0%BA%D1%86%D0%B8%D1%8F-%D0%B4%D0%BB%D1%8F-%D0%BF%D1%80%D0%B5%D0%BE%D0%B1%D1%80%D0%B0%D0%B7%D0%BE%D0%B2%D0%B0%D0%BD%D0%B8%D1%8F-%D0%BD%D0%BE%D0%BC%D0%B5%D1%80%D0%B0-%D1%81%D1%82%D0%BE%D0%BB%D0%B1%D1%86%D0%B0-%D0%B2-%D0%B1%D1%83%D0%BA%D0%B2%D1%83
Function OneTwoThree(ByVal nCol&) As String ' выбыл из-за некорректного преобразования
If nCol < 27 Then OneTwoThree = Chr$(64 + nCol): Exit Function 'A
If nCol < 677 Then OneTwoThree = Chr$(64 + Int(nCol / 26)) & Chr$(64 + nCol - (Int(nCol / 26) * 26)): Exit Function ' AA
OneTwoThree = Chr$(64 + Int(nCol / 676)) & Chr$(64 + Int(nCol - Int(nCol / 676) * 676) / 26) & Chr$(64 + nCol - (Int(nCol - Int(nCol / 676) * 676) / 26) * 26) ' AAA
End Function
'====================================================================================================
Public Function JanW(ByVal nCol&) As String ' выбыл из-за переполнения стэка
JanW = JanW(Int((nCol - 1) / 26)) & Chr$(((nCol - 1) Mod 26) + Asc("A"))
End Function
'====================================================================================================
Function Recur2(ByVal nCol&) As String ' выбыл из-за некорректного преобразования
Dim iAlpha&, iRemainder&
iAlpha = Int(nCol / 27)
iRemainder = nCol - (iAlpha * 26)
If iAlpha > 0 Then Recur2 = Chr$(iAlpha + 64)
If iRemainder > 0 Then Recur2 = Recur2 & Chr$(iRemainder + 64)
End Function
'====================================================================================================
Выводы: Честно говоря, на таких скоростях, уже без разницы, какую из этих двух функций использовать, т.к. разницу пользователь вряд ли заметит К тому же - данная функция у меня является лишь частью общей задачи, а значит её время работы будет лишь частью общего времени, а значит будет ещё менее заметно
Отдельное спасибо bedvit'у — единственному, кто составил конкуренцию представленным функциям Тесты проведены, результаты описаны и сохранены на Планете — это главное
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 10.09.2017
27.05.2021 11:44:01
Здравствуйте, Алексей! Спасибо за очередную интересную тему! В качестве послесловия:
Код
Function Newbie(ByVal n As Long) As String
Static init As Long, a(1 To 16384) As String
Dim i As Long
If init = 0 Then
For i = 1 To UBound(a)
a(i) = Recur(i)
Next i
init = 1
End If
Newbie = a(n)
End Function
sokol92, приветствую и спасибо ВАМ за такую оценку, Владимир! Ничего себе "послесловие" Это ж ГЕНИАЛЬНО! В такие моменты думаешь, "почему Я до этого не додумался" А ведь я тестил статику, но на словарях - а нафига словари, если по индексу массива можно всяко быстрее доставать без всякого поиска - балда я Вот только не пойму, почему вариант от Виталия стал так сильно тормозить — не было такого…
Отчёт (конкурентов нет)
Сравнение
Коды
Код
Option Explicit
Option Private Module
'====================================================================================================
Sub Start()
Dim i&
'Tester 1, "kaz": Exit Sub
shComp.Range("B3:E6").ClearContents
For i = 1 To 4
If Not Tester(i) Then Exit Sub
Next i
End Sub
'====================================================================================================
Function Tester(iType1To4&, Optional txCDMR$) As Boolean
Dim arr(), arrTime() As Long, arrNum() As Long, arrLtr() As String
Dim tx$, nCyc&, c&, c1&, c2&, i&
If iType1To4 = 1 Then
c1 = 1: c2 = 26: ' A-Z
nCyc = 100000
ElseIf iType1To4 = 2 Then
c1 = 27: c2 = 702: ' AA-ZZ
nCyc = 1000
ElseIf iType1To4 = 3 Then
c1 = 703: c2 = Columns.Count ' AAA-End
nCyc = 100
ElseIf iType1To4 = 4 Then
c1 = 1: c2 = Columns.Count ' ALL (A-End 16 384 columns)
nCyc = 100
Else
Err.Raise xlErrNA
End If
ReDim arrNum(c2 - c1): i = -1
ReDim arrLtr(UBound(arrNum))
For c = c1 To c2
i = i + 1: arrNum(i) = c
tx = Columns(c).Address(0, 0, xlA1)
arrLtr(i) = Left$(tx, InStr(tx, ":") - 1)
Next c
If Len(txCDMR) Then
Debug.Print iType1To4, txCDMR, FuncTest(txCDMR, nCyc, arrNum, arrLtr)
Tester = True: Exit Function
End If
arr = Array("o", "r", "b")
ReDim arrTime(1 To UBound(arr) + 2, 1 To 1)
arrTime(1, 1) = nCyc
For i = 0 To UBound(arr)
c = FuncTest(arr(i), nCyc, arrNum, arrLtr)
If c = -1 Then Exit Function Else arrTime(i + 2, 1) = c
Next i
shComp.Cells(3, iType1To4 + 1).Resize(UBound(arrTime), 1).Value2 = arrTime
Tester = True
End Function
'====================================================================================================
Function FuncTest(ByVal txCDMR$, nCycles&, arrNum() As Long, arrLtr() As String) As Long
Dim tx$, t!, cyc&, i&
Dim fOther As Boolean, fBed As Boolean, fRec As Boolean
tx = LCase$(txCDMR)
If tx = "o" Then fOther = True: txCDMR = "Other": GoTo nx1
If tx = "r" Then fRec = True: txCDMR = "Recur": GoTo nx1
If tx = "b" Then fBed = True: txCDMR = "BedVit": GoTo nx1
Err.Raise xlErrNA
nx1: t = Timer
For cyc = 1 To nCycles
For i = 0 To UBound(arrNum)
If fOther Then tx = Other(arrNum(i)): GoTo nx2
If fRec Then tx = Recur(arrNum(i)): GoTo nx2
If fBed Then tx = BedVit(arrNum(i)): GoTo nx2
If tx <> arrLtr(i) Then MsgBox tx & "<>" & arrLtr(i), vbCritical, txCDMR: FuncTest = -1: Exit Function
nx2: Next i
Next cyc
FuncTest = 1000 * (Timer - t)
End Function
'====================================================================================================
Sub Checker()
Dim ltr$, res$, c&
For c = 1 To Columns.Count
ltr = Columns(c).Address(0, 0, xlA1)
ltr = Left$(ltr, InStr(ltr, ":") - 1)
res = Other(c)
If ltr <> res Then MsgBox "The Column #" & Format$(c, "#,##0") & " have letter(s) «" & ltr & "», but testFunc return «" & res & "»", vbCritical, "UnCorrect result": Exit Sub
Next c
MsgBox "SUCCESS", vbInformation
End Sub
'====================================================================================================
'====================================================================================================
Function Other(ByVal nCol&) As String
Static init&, a(1 To 16384) As String
Dim i&
If init = 0 Then
For i = 1 To UBound(a)
a(i) = Recur(i)
Next i
init = 1
End If
Other = a(nCol)
End Function
'----------------------------------------------------------------------------------------------------
Function Recur(ByVal nCol&) As String
Dim lAlpha&, lRemainder&
If nCol <= 26 Then Recur = Chr$(nCol + 64): Exit Function
lRemainder = nCol Mod 26
If lRemainder = 0 Then
lRemainder = 26
lAlpha = lAlpha = Int(nCol / 26) - 1
Else
lAlpha = Int(nCol / 26)
End If
Recur = Recur(lAlpha) & Chr$(lRemainder + 64)
End Function
'----------------------------------------------------------------------------------------------------
Function BedVit(nCol&) As String
Dim AAA() As Byte
Dim cQUO&, cQUO2&, cMOD&, cMOD2&
If nCol <= 26 Then BedVit = Chr$(nCol + 64): Exit Function
If nCol <= 702 Then '<= 702 или < 703 — не влияет на скорость
ReDim AAA(0 To 3) As Byte
cQUO = nCol \ 26
cMOD = nCol Mod 26
If cMOD = 0 Then cQUO = cQUO - 1: cMOD = 26
AAA(0) = cQUO + 64
AAA(2) = cMOD + 64
Else
ReDim AAA(0 To 5) As Byte
cQUO = nCol \ 26
cMOD = nCol Mod 26
cQUO2 = (nCol - 26) \ 676 '(26 * 26)
cMOD2 = (nCol - 26) Mod 676
If cMOD2 = 0 Then cQUO2 = cQUO2 - 1
If cMOD = 0 Then cQUO = cQUO - 1: cMOD = 26
AAA(0) = cQUO2 + 64
AAA(2) = (cQUO - cQUO2 * 26) + 64
AAA(4) = cMOD + 64
End If
BedVit = AAA
End Function
'====================================================================================================
ща попробую счётчик на флаг заменить и сравнить на бОльшем цикле
Отчёт
Сравнение
Коды
Код
Option Explicit
Option Private Module
'====================================================================================================
Sub Start()
Dim i&
'Tester 1, "kaz": Exit Sub
shComp.Range("B3:E6").ClearContents
For i = 1 To 4
If Not Tester(i) Then Exit Sub
Next i
End Sub
'====================================================================================================
Function Tester(iType1To4&, Optional txCDMR$) As Boolean
Dim arr(), arrTime() As Long, arrNum() As Long, arrLtr() As String
Dim tx$, nCyc&, c&, c1&, c2&, i&
If iType1To4 = 1 Then
c1 = 1: c2 = 26: ' A-Z
nCyc = 1000000
ElseIf iType1To4 = 2 Then
c1 = 27: c2 = 702: ' AA-ZZ
nCyc = 10000
ElseIf iType1To4 = 3 Then
c1 = 703: c2 = Columns.Count ' AAA-End
nCyc = 1000
ElseIf iType1To4 = 4 Then
c1 = 1: c2 = Columns.Count ' ALL (A-End 16 384 columns)
nCyc = 1000
Else
Err.Raise xlErrNA
End If
ReDim arrNum(c2 - c1): i = -1
ReDim arrLtr(UBound(arrNum))
For c = c1 To c2
i = i + 1: arrNum(i) = c
tx = Columns(c).Address(0, 0, xlA1)
arrLtr(i) = Left$(tx, InStr(tx, ":") - 1)
Next c
If Len(txCDMR) Then
Debug.Print iType1To4, txCDMR, FuncTest(txCDMR, nCyc, arrNum, arrLtr)
Tester = True: Exit Function
End If
arr = Array("r", "s")
ReDim arrTime(1 To UBound(arr) + 2, 1 To 1)
arrTime(1, 1) = nCyc
For i = 0 To UBound(arr)
c = FuncTest(arr(i), nCyc, arrNum, arrLtr)
If c = -1 Then Exit Function Else arrTime(i + 2, 1) = c
Next i
shComp.Cells(3, iType1To4 + 1).Resize(UBound(arrTime), 1).Value2 = arrTime
Tester = True
End Function
'====================================================================================================
Function FuncTest(ByVal txCDMR$, nCycles&, arrNum() As Long, arrLtr() As String) As Long
Dim tx$, t!, cyc&, i&
Dim fRec As Boolean, fSokol As Boolean
tx = LCase$(txCDMR)
If tx = "r" Then fRec = True: txCDMR = "Recur": GoTo nx1
If tx = "s" Then fSokol = True: txCDMR = "Sokol": GoTo nx1
Err.Raise xlErrNA
nx1: t = Timer
For cyc = 1 To nCycles
For i = 0 To UBound(arrNum)
If fRec Then tx = Recur(arrNum(i)): GoTo nx2
If fSokol Then tx = Sokol(arrNum(i)): GoTo nx2
nx2: If tx <> arrLtr(i) Then MsgBox tx & "<>" & arrLtr(i), vbCritical, txCDMR: FuncTest = -1: Exit Function
Next i
Next cyc
FuncTest = 1000 * (Timer - t)
End Function
'====================================================================================================
Sub Checker()
Dim ltr$, res$, c&
For c = 1 To Columns.Count
ltr = Columns(c).Address(0, 0, xlA1)
ltr = Left$(ltr, InStr(ltr, ":") - 1)
res = Sokol(c)
If ltr <> res Then MsgBox "The Column #" & Format$(c, "#,##0") & " have letter(s) «" & ltr & "», but testFunc return «" & res & "»", vbCritical, "UnCorrect result": Exit Sub
Next c
MsgBox "SUCCESS", vbInformation
End Sub
'====================================================================================================
'====================================================================================================
Function Sokol(ByVal nCol&) As String
Dim ch&, i&
Static a(1 To 16384) As String, fStatic As Boolean
If Not fStatic Then
fStatic = True
For ch = 65 To 90
i = i + 1: a(i) = Chr$(ch)
Next ch
For i = 27 To 16384
a(i) = Recur(i)
Next i
End If
Sokol = a(nCol)
End Function
'----------------------------------------------------------------------------------------------------
Function Recur(ByVal nCol&) As String
Dim lAlpha&, lRemainder&
If nCol <= 26 Then Recur = Chr$(nCol + 64): Exit Function
lRemainder = nCol Mod 26
If lRemainder = 0 Then
lRemainder = 26
lAlpha = Int(nCol / 26) - 1
Else
lAlpha = Int(nCol / 26)
End If
Recur = Recur(lAlpha) & Chr$(lRemainder + 64)
End Function
'====================================================================================================
не понимаю, почему даже на миллионе вызовов 26ти однобуквенных столбцов, вычисляемая функция Chr$()выигрывает у получения элемента из массива по индексу Я буду использовать вариант от Владимира и ещё раз зарублю себе про мощь статики
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 02.04.2015
Виталий
27.05.2021 12:48:08
Ого, Владимир - респект! Раз такая пьянка пошла, сделал некоторые улучшения и в своей функции, тестируйте
Код
Function C1toA1_v2(col As Long) As String 'номер столбца в букву
Dim cQUO As Long, cMOD As Long, cQUO2 As Long, cMOD2 As Long
If col <= 26 Then ' одна буква
C1toA1_v2 = Chr$(col + 64)
ElseIf col <= 702 Then ' 2 буквы
cQUO = col \ 26
cMOD = col Mod 26
If cMOD = 0 Then cQUO = cQUO - 1: cMOD = 26
C1toA1_v2 = Chr$(cQUO + 64) & Chr$(cMOD + 64)
Else ' 3 буквы
cQUO = col \ 26
cMOD = col Mod 26
cQUO2 = (col - 26) \ 676 '(26 * 26)
cMOD2 = (col - 26) Mod 676
If cMOD2 = 0 Then cQUO2 = cQUO2 - 1
If cMOD = 0 Then cQUO = cQUO - 1: cMOD = 26
C1toA1_v2 = Chr$(cQUO2 + 64) & Chr$((cQUO - cQUO2 * 26) + 64) & Chr$(cMOD + 64)
End If
End Function
bedvit, да блин — только к твоему суперсловарю вернулся Ща
Рекурсия побеждена
Поздравляю, Виталь, и с возвращением Сейчас объединю твой вариант со статикой и можно расходится, я думаю Скорость просто фантастическая!
Финальный отчёт
Сравнение
Коды
Код
Option Explicit
Option Private Module
'====================================================================================================
Sub Start()
Dim i&
'Tester 1, "kaz": Exit Sub
shComp.Range("B5:E7").ClearContents
For i = 1 To 4
If Not Tester(i) Then Exit Sub
Next i
End Sub
'====================================================================================================
Function Tester(iType1To4&, Optional txCDMR$) As Boolean
Dim arr(), arrTime() As Long, arrNum() As Long, arrLtr() As String
Dim tx$, nCyc&, c&, c1&, c2&, i&
If iType1To4 = 1 Then
c1 = 1: c2 = 26: ' A-Z
nCyc = 1000000
ElseIf iType1To4 = 2 Then
c1 = 27: c2 = 702: ' AA-ZZ
nCyc = 10000
ElseIf iType1To4 = 3 Then
c1 = 703: c2 = Columns.Count ' AAA-End
nCyc = 1000
ElseIf iType1To4 = 4 Then
c1 = 1: c2 = Columns.Count ' ALL (A-End 16 384 columns)
nCyc = 1000
Else
Err.Raise xlErrNA
End If
ReDim arrNum(c2 - c1): i = -1
ReDim arrLtr(UBound(arrNum))
For c = c1 To c2
i = i + 1: arrNum(i) = c
tx = Columns(c).Address(0, 0, xlA1)
arrLtr(i) = Left$(tx, InStr(tx, ":") - 1)
Next c
If Len(txCDMR) Then
Debug.Print iType1To4, txCDMR, FuncTest(txCDMR, nCyc, arrNum, arrLtr)
Tester = True: Exit Function
End If
arr = Array("b", "r")
ReDim arrTime(1 To UBound(arr) + 2, 1 To 1)
arrTime(1, 1) = nCyc
For i = 0 To UBound(arr)
c = FuncTest(arr(i), nCyc, arrNum, arrLtr)
If c = -1 Then Exit Function Else arrTime(i + 2, 1) = c
Next i
shComp.Cells(5, iType1To4 + 1).Resize(UBound(arrTime), 1).Value2 = arrTime
Tester = True
End Function
'====================================================================================================
Function FuncTest(ByVal txCDMR$, nCycles&, arrNum() As Long, arrLtr() As String) As Long
Dim tx$, t!, cyc&, i&
Dim fBed As Boolean, fRec As Boolean
tx = LCase$(txCDMR)
If tx = "b" Then fBed = True: txCDMR = "BedVit": GoTo nx1
If tx = "r" Then fRec = True: txCDMR = "Recur": GoTo nx1
Err.Raise xlErrNA
nx1: t = Timer
For cyc = 1 To nCycles
For i = 0 To UBound(arrNum)
If fBed Then tx = BedStat(arrNum(i)): GoTo nx2
If fRec Then tx = RecStat(arrNum(i)): GoTo nx2
nx2: If tx <> arrLtr(i) Then MsgBox tx & "<>" & arrLtr(i), vbCritical, txCDMR: FuncTest = -1: Exit Function
Next i
Next cyc
FuncTest = 1000 * (Timer - t)
End Function
'====================================================================================================
Sub Checker()
Dim ltr$, res$, c&
For c = 1 To Columns.Count
ltr = Columns(c).Address(0, 0, xlA1)
ltr = Left$(ltr, InStr(ltr, ":") - 1)
res = RecStat(c)
If ltr <> res Then MsgBox "The Column #" & Format$(c, "#,##0") & " have letter(s) «" & ltr & "», but testFunc return «" & res & "»", vbCritical, "UnCorrect result": Exit Sub
Next c
MsgBox "SUCCESS", vbInformation
End Sub
'====================================================================================================
'====================================================================================================
Function BedStat(nCol&) As String
Dim ch&, i&
Static a(1 To 16384) As String, fStatic As Boolean
If Not fStatic Then
fStatic = True
For ch = 65 To 90
i = i + 1: a(i) = Chr$(ch)
Next ch
For i = 27 To 16384
a(i) = BedVit(i)
Next i
End If
BedStat = a(nCol)
End Function
'----------------------------------------------------------------------------------------------------
Function RecStat(nCol&) As String
Dim ch&, i&
Static a(1 To 16384) As String, fStatic As Boolean
If Not fStatic Then
fStatic = True
For i = 1 To 16384
a(i) = Recur(i)
Next i
End If
RecStat = a(nCol)
End Function
'====================================================================================================
'====================================================================================================
Function BedVit(nCol&) As String
Dim cQUO As Long, cMOD As Long, cQUO2 As Long, cMOD2 As Long
If nCol <= 702 Then
cQUO = nCol \ 26
cMOD = nCol Mod 26
If cMOD = 0 Then cQUO = cQUO - 1: cMOD = 26
BedVit = Chr$(cQUO + 64) & Chr$(cMOD + 64)
Else
cQUO = nCol \ 26
cMOD = nCol Mod 26
cQUO2 = (nCol - 26) \ 676
cMOD2 = (nCol - 26) Mod 676
If cMOD2 = 0 Then cQUO2 = cQUO2 - 1
If cMOD = 0 Then cQUO = cQUO - 1: cMOD = 26
BedVit = Chr$(cQUO2 + 64) & Chr$((cQUO - cQUO2 * 26) + 64) & Chr$(cMOD + 64)
End If
End Function
'----------------------------------------------------------------------------------------------------
Function Recur(nCol&) As String
Dim lAlpha&, lRemainder&
If nCol <= 26 Then Recur = Chr$(64 + nCol): Exit Function
lRemainder = nCol Mod 26
If lRemainder = 0 Then
lRemainder = 26
lAlpha = Int(nCol / 26) - 1
Else
lAlpha = Int(nCol / 26)
End If
Recur = Recur(lAlpha) & Chr$(lRemainder + 64)
End Function
'====================================================================================================
