Excel VBA - Чрезвычайно медленная окраска ячеек

Question

У меня есть серия CSV-файлов, которые я импортирую, которые содержат информацию о цвете, которую мне нужно применить к импортированным данным. Колонка цвета двоеточий, а данные трубы разделителей:

:::::65535::|ADAM 14-22TGH|CHERRY|twu|Diesel Fuel (RIG)|Fuel|| 
::::14994616:::|MARCO 41-12G|CRYSTAL|HVA|Diesel Fuel (RIG)|Rig Fuel|gal us| 
:::65535:65535:65535:65535:|MARCO 41-12G|CRYSTAL||||| 

лист Excel содержит определенные цвета для различных состояний данных (отсутствующие данные, неправильные данные, слишком высоко, слишком низко, и т.д.), поэтому я Переберите импортируемых данные строящих объединение клеток, которые я в конце концов применить раскрашивание к:

Dim ds As Worksheet 
Dim i As Long, j As Long, k As Long 
Dim iUsedCol As Long, iUsedRow As Long, clrRequired As Long, color as Long 
Dim rngRequired As Range 

Dim colorMap As Variant 
Dim colors() As String 
clrRequired = CLng(GetSetting("Failed Required Field Check")) 

' Get the values of the color column 
iusedRow = ds.UsedRange.Rows.Count 
colorMap = Range(ds.Cells(1, 1), Cells(iUsedRow, 1)).Value 

' Delete the color map column 
ds.Columns(1).EntireColumn.Delete 

' Skip the first two rows 
For i = 3 To iusedRow 
    colors = Split(colorMap(i, 1), ":") 

    ' Offset by one column since we're deleting column 1 after 
    For j = 2 To UBound(colors) + 1 
     If colors(j - 1) = "" Then 
     Else 
      color = CLng(colors(j - 1)) 

      ' Required 
      If color = clrRequired Then 
       If rngRequired Is Nothing Then 
        Set rngRequired = ds.Cells(i, j) 
       Else 
        Set rngRequired = Application.Union(rngRequired, ds.Cells(i, j)) 
       End If 
      End If 
     End If 
    Next j 
Next i 

' Set the colors 
If Not rngRequired Is Nothing Then 
    rngRequired.Interior.color = clrRequired 
End If 

для простоты я снял еще три идентичных проверку для других цветов, но это картина. В зависимости от данных это может быть 50 строк или 12000 строк с разными столбцами на основе того, что проверяется. У меня есть отчет, на который уходит более 20 минут, и когда я удаляю этот код, он заканчивается примерно через 10 секунд.

Кроме того вот, что я отключить во время выполнения кода:

• Расчеты
• CancelKey
• PrintCommunication
• ScreenUpdating
• События
• StatusBar
• Alerts

Answer 1

Попробуйте следующий код:

Dim ds As Worksheet 
Dim i As Long, j As Long, k As Long 
Dim iUsedCol As Long, iUsedRow As Long, clrRequired As Long, color As Long 

'... 
'Set ds = ..... 
'... 

iUsedRow = ds.UsedRange.Rows.Count 

' Skip the first two rows 
For i = 3 To iUsedRow 
    colors = Split(ds.Cells(i, 1).Value, ":") 

    ' Offset by one column since we're deleting column 1 after 
    For j = 2 To UBound(colors) + 1 
     If colors(j - 1) <> "" Then 
      ds.Cells(i, j).Interior.color = CLng(colors(j - 1)) 
     End If 
    Next j 
Next i 

' Delete the color map column 
ds.Columns(1).EntireColumn.Delete 

Это будет обрабатывать все цвета в одном цикле. (Это может быть проблемой, если вы только пытаетесь установить определенные цвета, как определено вашими вызовами GetSetting. Если это так, вам может потребоваться включить оператор If, чтобы избежать обработки, если указанный цвет не является одним из цветов, которые вы хотите для обработки.)