ПОЖАЛУЙСТА, ВИДИТЕ ОТВЕТ АХМЕДА АУ В КОНЦЕ - ЕГО РЕШЕНИЕ ФАНТАСТИЧНО! После моего старого кода, у меня есть последняя версия. Разница в скорости поражает!
НАЧАЛЬНЫЙ ВОПРОС:
Я конвертирую серию таблиц Excel в темную тему. Для этого я написал простой макрос (см. Ниже), который заменяет текущие цвета (например, фон, цвет текста и границы) конкретными цветами RGB. Код работает хорошо, но преобразование одной таблицы занимает слишком много времени. Мои рабочие тетради - это большие финансовые модели, каждая из которых содержит несколько таблиц. Я ожидал, что каждая отдельная электронная таблица (скажем, 300 строк, 50 столбцов) преобразуется за несколько секунд. Это занимает 30 минут на таблицу!
Важно отметить, что автоматический расчет выключен (и мне все равно не нужно ничего пересчитывать, чтобы запустить этот макрос)
Код, который я использую, находится ниже [ ЭТО СТАРЫЙ КОД - СМОТРИ НОВЫЙ КОД НИЖЕ ]:
Sub Dark_mode()
Dim iR, iG, iB, fR, fG, fB As Integer
Dim current_line, current_column As Integer
Dim c_c As Range
Dim OldStatusBar As Boolean, current_run, line_start, line_end, column_start, column_end As Integer
'Prevents screen refreshing
Application.ScreenUpdating = False
OldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
' SET HERE LINES AND COLUMNS TO TRANSFORM
line_start = 211
line_end = 223
column_start = 1
column_end = 160
For current_line = line_start To line_end
DoEvents
Application.StatusBar = ">>>>>>> FORMATING: " & Format((current_line - line_start) / (line_end - line_start), "0%") & " completed <<<<<<<"
For current_column = column_start To column_end
Set c_c = Cells(current_line, current_column)
With c_c.Interior
iR = .Color Mod 256
iG = (.Color Mod 256 ^ 2) \ 256
iB = .Color \ (256 ^ 2)
End With
With c_c.Font
fR = .Color Mod 256
fG = (.Color Mod 256 ^ 2) \ 256
fB = .Color \ (256 ^ 2)
End With
'CORE BACKGROUND
If iR = 255 And iG = 255 And iB = 255 Then c_c.Interior.Color = RGB(51, 51, 51) 'white TO background I
If iR = 227 And iG = 227 And iB = 227 Then c_c.Interior.Color = RGB(41, 41, 41) 'light gray TO background II
If iR = 192 And iG = 192 And iB = 192 Then c_c.Interior.Color = RGB(0, 0, 0) 'dark gray TO backgroun III
'CORE TOPIC
If iR = 0 And iG = 0 And iB = 0 Then c_c.Interior.Color = RGB(0, 102, 0) 'black TO green
' Ad hoc grays converted to green
If iR = 128 And iG = 128 And iB = 128 Then c_c.Interior.Color = RGB(0, 102, 0) 'gray TO green
If iR = 217 And iG = 217 And iB = 217 Then c_c.Interior.Color = RGB(0, 102, 0) 'gray TO green
'CORE INPUT
If iR = 255 And iG = 255 And iB = 153 Then c_c.Interior.Color = RGB(0, 51, 153) 'yellow TO blue
If iR = 255 And iG = 255 And iB = 0 Then c_c.Interior.Color = RGB(120, 25, 25) 'bright yellow TO red
'CORE TEXT
If fR = 0 And fG = 0 And fB = 0 Then c_c.Font.Color = RGB(255, 255, 255) 'black TO white
If fR = 0 And fG = 0 And fB = 255 Then c_c.Font.Color = RGB(0, 255, 0) 'blue TO green
If fR = 0 And fG = 128 And fB = 0 Then c_c.Font.Color = RGB(0, 176, 240) 'green TO blue
If fR = 128 And fG = 0 And fB = 128 Then c_c.Font.Color = RGB(255, 204, 0) 'magenta TO orange
If fR = 0 And fG = 128 And fB = 128 Then c_c.Font.Color = RGB(0, 204, 152) 'light blue TO pale green
'CORE BORDERS (bottom/top/right/left colors)
If c_c.Borders(xlEdgeBottom).LineStyle <> -4142 Then
With c_c.Borders(xlEdgeBottom)
.Color = RGB(255, 217, 102)
End With
End If
If c_c.Borders(xlEdgeTop).LineStyle <> -4142 Then
With c_c.Borders(xlEdgeTop)
.Color = RGB(255, 217, 102)
End With
End If
If c_c.Borders(xlEdgeRight).LineStyle <> -4142 Then
With c_c.Borders(xlEdgeRight)
.Color = RGB(255, 217, 102)
End With
End If
If c_c.Borders(xlEdgeLeft).LineStyle <> -4142 Then
With c_c.Borders(xlEdgeLeft)
.Color = RGB(255, 217, 102)
End With
End If
Next current_column
Next current_line
'Enables screen refreshing
Application.ScreenUpdating = True
Application.StatusBar = False
Application.DisplayStatusBar = OldStatusBar
End Sub
ЭТО НОВЫЙ КОД:
Sub Dark_mode()
' worksheet and range variables
Dim Ws As Worksheet
Dim Rng As Range
' loop variables
Dim line_start As Integer, line_end As Integer, column_start As Integer, column_end As Integer
Dim Rw As Long, Col As Long
'current cell colors (for interior, font and border)
Dim IntClr As Long, FntClr As Long, BrdL As Long, BrdR As Long, BrdT As Long, BrdB As Long
Dim LnCnt As Long, ColCnt As Long
Dim iR As Integer, iG As Integer, iB As Integer, fR As Integer, fG As Integer, fB As Integer
' [i]nterior color variables
Dim IcRng1 As Range, IcRng2 As Range, IcRng3 As Range, IcRng4 As Range, IcRng5 As Range, IcRng6 As Range
Dim IClr1 As Long, IClr2 As Long, IClr3 As Long, IClr4 As Long, IClr5 As Long, IClr6 As Long
'[f]ont color variables
Dim fcRng1 As Range, fcRng2 As Range, fcRng3 As Range, fcRng4 As Range, fcRng5 As Range, fcRng6 As Range, fcRng7 As Range, fcRng8 As Range
Dim fClr1 As Long, fClr2 As Long, fClr3 As Long, fClr4 As Long, fClr5 As Long, fClr6 As Long, fClr7 As Long, fClr8 As Long
'[brd] color variables
Dim BrdRngL As Range, BrdRngR As Range, BrdRngT As Range, BrdRngB As Range
Dim BrdClr As Long
' SET HERE LINES AND COLUMNS TO TRANSFORM
line_start = 1
line_end = 130
column_start = 1
column_end = 45
LnCnt = line_end - line_start + 1
ColCnt = column_end - column_start + 1
'SET COLOR PATERNS FOR INTERIOR, TEXT AND BORDER
'Interior colors
IClr1 = RGB(51, 51, 51) 'format TO Core I
IClr2 = RGB(41, 41, 41) 'format TO Core II
IClr3 = RGB(0, 0, 0) 'format TO Core III
IClr4 = RGB(36, 64, 98) 'format TO Input
IClr5 = RGB(99, 37, 35) 'format to Special
IClr6 = RGB(33, 89, 103) 'format to Topic
'Font colors
fClr1 = RGB(255, 255, 255) 'format TO white (Core text / formula)
fClr2 = RGB(102, 204, 255) 'format TO blue (Number only)
fClr3 = RGB(204, 255, 102) 'format TO light green (Estimated figure)
fClr4 = RGB(255, 153, 102) 'format TO dark orange (Formula + number)
fClr5 = RGB(255, 204, 0) 'format TO orange (Other spreadsheet)
fClr6 = RGB(0, 255, 0) 'format TO bright green (FDS formula)
fClr7 = RGB(0, 255, 0) 'format TO magenta (Needs work)
fClr8 = RGB(0, 255, 0) 'format TO grey (Dim light)
'Border color
BrdClr = RGB(255, 217, 102) 'all borders to same color (yellow)
Set Ws = ThisWorkbook.ActiveSheet
Set Rng = Ws.Range(Cells(line_start, column_start), Cells(line_end, column_end))
tm = Timer()
Debug.Print ">>>>> STARTING LOOPS @ " & Now()
For Rw = 1 To LnCnt
For Col = 1 To ColCnt
IntClr = Rng(Rw, Col).Interior.Color
iR = IntClr Mod 256
iG = (IntClr Mod 256 ^ 2) \ 256
iB = IntClr \ (256 ^ 2)
FntClr = Rng(Rw, Col).Cells.Font.Color
fR = FntClr Mod 256
fG = (FntClr Mod 256 ^ 2) \ 256
fB = FntClr \ (256 ^ 2)
BrdL = Rng(Rw, Col).Borders(xlEdgeLeft).LineStyle
BrdR = Rng(Rw, Col).Borders(xlEdgeRight).LineStyle
BrdT = Rng(Rw, Col).Borders(xlEdgeTop).LineStyle
BrdB = Rng(Rw, Col).Borders(xlEdgeBottom).LineStyle
'CORE BACKGROUNDS
If iR = 255 And iG = 255 And iB = 255 Then Set IcRng1 = SimpleUnion(IcRng1, Rng(Rw, Col)) 'white to "Core I"
If iR = 227 And iG = 227 And iB = 227 Then Set IcRng2 = SimpleUnion(IcRng2, Rng(Rw, Col)) 'light gray to "Core II"
If iR = 192 And iG = 192 And iB = 192 Then Set IcRng3 = SimpleUnion(IcRng3, Rng(Rw, Col)) 'dark gray to "Core III"
'Ad hoc colors converted to Core I/II/III
If iR = 242 And iG = 242 And iB = 242 Then Set IcRng2 = SimpleUnion(IcRng2, Rng(Rw, Col)) 'light blue to "Input"
'CORE INPUT
If iR = 255 And iG = 255 And iB = 153 Then Set IcRng4 = SimpleUnion(IcRng4, Rng(Rw, Col)) 'LIGHT yellow to "Input"
'Ad hoc colors converted to Input
If iR = 204 And iG = 255 And iB = 255 Then Set IcRng4 = SimpleUnion(IcRng4, Rng(Rw, Col)) 'light blue to "Input"
'CORE SPECIAL
If iR = 255 And iG = 255 And iB = 0 Then Set IcRng5 = SimpleUnion(IcRng5, Rng(Rw, Col)) 'bright yellow to "Special"
'CORE TOPIC
If iR = 0 And iG = 0 And iB = 0 Then Set IcRng6 = SimpleUnion(IcRng6, Rng(Rw, Col)) 'black to "Topic"
' Ad hoc colors converted to TOPIC
If iR = 0 And iG = 0 And iB = 128 Then Set IcRng6 = SimpleUnion(IcRng6, Rng(Rw, Col)) 'dark blue to "Topic"
If iR = 128 And iG = 128 And iB = 128 Then Set IcRng6 = SimpleUnion(IcRng6, Rng(Rw, Col)) 'dark gray to "Topic"
If iR = 217 And iG = 217 And iB = 217 Then Set IcRng6 = SimpleUnion(IcRng6, Rng(Rw, Col)) 'light gray to "Topic"
'CORE TEXT
If fR = 0 And fG = 0 And fB = 0 Then Set fcRng1 = SimpleUnion(fcRng1, Rng(Rw, Col)) 'black to "Core text / formula"
If fR = 0 And fG = 0 And fB = 255 Then Set fcRng2 = SimpleUnion(fcRng2, Rng(Rw, Col)) 'blue to "Number only"
If fR = 0 And fG = 128 And fB = 128 Then Set fcRng3 = SimpleUnion(fcRng3, Rng(Rw, Col)) 'light blue to "Estimated figure"
If fR = 128 And fG = 0 And fB = 128 Then Set fcRng5 = SimpleUnion(fcRng5, Rng(Rw, Col)) 'magenta to "Other Spreadsheet"
If fR = 0 And fG = 128 And fB = 0 Then Set fcRng6 = SimpleUnion(fcRng6, Rng(Rw, Col)) 'green to "FDS formula"
'CORE BORDERS (bottom/top/right/left colors)
If BrdL <> -4142 Then Set BrdRngL = SimpleUnion(BrdRngL, Rng(Rw, Col))
If BrdR <> -4142 Then Set BrdRngR = SimpleUnion(BrdRngR, Rng(Rw, Col))
If BrdT <> -4142 Then Set BrdRngT = SimpleUnion(BrdRngT, Rng(Rw, Col))
If BrdB <> -4142 Then Set BrdRngB = SimpleUnion(BrdRngB, Rng(Rw, Col))
Next Col
Next Rw
Debug.Print "Calculations time (sec.): " & Timer() - tm
'Prevents screen refreshing
Application.ScreenUpdating = False
'Replace cell colors
If Not IcRng1 Is Nothing Then IcRng1.Interior.Color = IClr1
If Not IcRng2 Is Nothing Then IcRng2.Interior.Color = IClr2
If Not IcRng3 Is Nothing Then IcRng3.Interior.Color = IClr3
If Not IcRng4 Is Nothing Then IcRng4.Interior.Color = IClr4
If Not IcRng5 Is Nothing Then IcRng5.Interior.Color = IClr5
If Not IcRng6 Is Nothing Then IcRng6.Interior.Color = IClr6
'Replace text colors
If Not fcRng1 Is Nothing Then fcRng1.Font.Color = fClr1
If Not fcRng2 Is Nothing Then fcRng2.Font.Color = fClr2
If Not fcRng3 Is Nothing Then fcRng3.Font.Color = fClr3
If Not fcRng4 Is Nothing Then fcRng4.Font.Color = fClr4
If Not fcRng5 Is Nothing Then fcRng5.Font.Color = fClr5
If Not fcRng6 Is Nothing Then fcRng6.Font.Color = fClr6
If Not fcRng7 Is Nothing Then fcRng7.Font.Color = fClr7
If Not fcRng8 Is Nothing Then fcRng8.Font.Color = fClr8
'Replace borders colors
If Not BrdRngL Is Nothing Then BrdRngL.Borders(xlEdgeLeft).Color = BrdClr
If Not BrdRngR Is Nothing Then BrdRngR.Borders(xlEdgeRight).Color = BrdClr
If Not BrdRngT Is Nothing Then BrdRngT.Borders(xlEdgeTop).Color = BrdClr
If Not BrdRngB Is Nothing Then BrdRngB.Borders(xlEdgeBottom).Color = BrdClr
Debug.Print "Total time (sec.): " & Timer - tm
'Enables screen refreshing
Application.ScreenUpdating = True
End Sub
Function SimpleUnion(Xrng As Range, Yrng As Range) As Range
If Xrng Is Nothing Then
Set SimpleUnion = Yrng
Else
Set SimpleUnion = Union(Xrng, Yrng)
End If
End Function
' Gets color for background/text on cell at (linha, coluna)
Sub Get_color()
Dim iR, iG, iB As Integer
Dim fR, fG, fB As Integer
Dim linha, current_column As Integer
linha = 21
coluna = 20
Debug.Print "--- --- --- --- INTERIOR AND FONT COLORS --- --- --- ---"
With ActiveSheet.Cells(linha, coluna).Interior
iR = .Color Mod 256
iG = (.Color Mod 256 ^ 2) \ 256
iB = .Color \ (256 ^ 2)
End With
Debug.Print "Interior: [" & iR & ", " & iG & ", " & iB & "]"
With ActiveSheet.Cells(linha, coluna).Font
fR = .Color Mod 256
fG = (.Color Mod 256 ^ 2) \ 256
fB = .Color \ (256 ^ 2)
End With
Debug.Print "Font: [" & fR & ", " & fG & ", " & fB & "]"
End Sub