Есть макрос который удаляет текст в ячейке если он не жирный, можно ли как то ускорить? на 5к строк он работает около 20 минут , а у меня файлы по 100к строк. [vba]
Код
Sub FilterBold() Dim xRg As Range, xCell As Range Dim xAddress As String On Error Resume Next xAddress = ActiveWindow.RangeSelection.Address Set xRg = Application.InputBox("Please select a range:", "Kutools for Excel", xAddress, , , , , 8) If xRg Is Nothing Then Exit Sub Application.ScreenUpdating = False For Each xCell In xRg If Not xCell.Font.Bold Then xCell.Delete '- если не жирный шрифт тогда-удалить Next Application.ScreenUpdating = True End Sub
[/vba] Спасибо
Есть макрос который удаляет текст в ячейке если он не жирный, можно ли как то ускорить? на 5к строк он работает около 20 минут , а у меня файлы по 100к строк. [vba]
Код
Sub FilterBold() Dim xRg As Range, xCell As Range Dim xAddress As String On Error Resume Next xAddress = ActiveWindow.RangeSelection.Address Set xRg = Application.InputBox("Please select a range:", "Kutools for Excel", xAddress, , , , , 8) If xRg Is Nothing Then Exit Sub Application.ScreenUpdating = False For Each xCell In xRg If Not xCell.Font.Bold Then xCell.Delete '- если не жирный шрифт тогда-удалить Next Application.ScreenUpdating = True End Sub
Sub FilterBold() Dim xRg As Range, xCell As Range, rng As Range Dim xAddress As String On Error Resume Next xAddress = ActiveWindow.RangeSelection.Address Set xRg = Application.InputBox("Please select a range:", "Kutools for Excel", xAddress, , , , , 8) If xRg Is Nothing Then Exit Sub
With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual End With
For Each xCell In xRg If Not xCell.Font.Bold Then 'xCell.Delete '- если не жирный шрифт тогда-удалить If rng Is Nothing Then Set rng = xCell 'первый раз Else Set rng = Union(rng, xCell) 'остальные разы End If End If
Next xCell
If Not rng Is Nothing Then rng.Delete
With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic End With End Sub
[/vba]
Привет!
[vba]
Код
Sub FilterBold() Dim xRg As Range, xCell As Range, rng As Range Dim xAddress As String On Error Resume Next xAddress = ActiveWindow.RangeSelection.Address Set xRg = Application.InputBox("Please select a range:", "Kutools for Excel", xAddress, , , , , 8) If xRg Is Nothing Then Exit Sub
With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual End With
For Each xCell In xRg If Not xCell.Font.Bold Then 'xCell.Delete '- если не жирный шрифт тогда-удалить If rng Is Nothing Then Set rng = xCell 'первый раз Else Set rng = Union(rng, xCell) 'остальные разы End If End If
Next xCell
If Not rng Is Nothing Then rng.Delete
With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic End With End Sub
Удаление ячеек в этой задачке занимает 99% времени работы макроса
Я порылся в таком направлении:
[vba]
Код
Sub ClearCells_Mika() Dim xRg As Range, xCell As Range Dim xAddress As String
On Error Resume Next xAddress = ActiveWindow.RangeSelection.Address Set xRg = Application.InputBox("Please select a range:", "Kutools for Excel", xAddress, , , , , 8) If xRg Is Nothing Then Exit Sub
Dim aTmp, lr&, lc& aTmp = xRg.Value For lr = 1 To UBound(aTmp) For lc = 1 To UBound(aTmp, 2) If Not xRg.Cells(lr, lc).Font.Bold Then aTmp(lr, lc) = Empty End If Next lc Next lr xRg.Value = aTmp
'Если таки нужно удалять: 'xRg.SpecialCells(xlCellTypeBlanks).Delete xlUp
Debug.Print "ClearCells_Mika: " & Format(Timer - t, "0.0000") End Sub
[/vba]
и для очистки ячеек, вышло хорошо но метод [vba]
Код
xRg.SpecialCells(xlCellTypeBlanks).Delete xlUp
[/vba] все-таки туговат, потому что удаляет сразу очень много ячеек,
Поэтому, я посмотрел в сторону строки+массива, и получил при удалении ячеек прирост в скорости порядка 20%:
[vba]
Код
Sub DeleteCells_Mika() Dim xRg As Range, xCell As Range Dim xAddress As String
On Error Resume Next xAddress = ActiveWindow.RangeSelection.Address Set xRg = Application.InputBox("Please select a range:", "Kutools for Excel", xAddress, , , , , 8) If xRg Is Nothing Then Exit Sub
Dim str$, ll&: str = "|": ll = 1 For Each xCell In xRg If Not xCell.Font.Bold Then str = str & xCell.Address(0, 0) & "," ll = ll + Len(xCell.Address(0, 0)) + 1 If ll >= 250 Then str = Left(str, Len(str) - 1) & "|": ll = 1 End If Next
If Len(str) > 1 Then str = Left(str, Len(str) - 1) Dim aTmp: aTmp = Split(str, "|") For ll = UBound(aTmp) To 1 Step -1 Range(aTmp(ll)).Delete xlUp 'Range(aTmp(ll)).ClearContents Next ll End If
Debug.Print "DeleteCells_Mika: " & Format(Timer - t, "0.0000") End Sub
[/vba]
Но при очистке ячеек он проигрывает примерно в 2 раза
Так что первый лучше для очистки, второй - для удаления. В тестах участвовали 40к ячеек. Было весело
Удаление ячеек в этой задачке занимает 99% времени работы макроса
Я порылся в таком направлении:
[vba]
Код
Sub ClearCells_Mika() Dim xRg As Range, xCell As Range Dim xAddress As String
On Error Resume Next xAddress = ActiveWindow.RangeSelection.Address Set xRg = Application.InputBox("Please select a range:", "Kutools for Excel", xAddress, , , , , 8) If xRg Is Nothing Then Exit Sub
Dim aTmp, lr&, lc& aTmp = xRg.Value For lr = 1 To UBound(aTmp) For lc = 1 To UBound(aTmp, 2) If Not xRg.Cells(lr, lc).Font.Bold Then aTmp(lr, lc) = Empty End If Next lc Next lr xRg.Value = aTmp
'Если таки нужно удалять: 'xRg.SpecialCells(xlCellTypeBlanks).Delete xlUp
Debug.Print "ClearCells_Mika: " & Format(Timer - t, "0.0000") End Sub
[/vba]
и для очистки ячеек, вышло хорошо но метод [vba]
Код
xRg.SpecialCells(xlCellTypeBlanks).Delete xlUp
[/vba] все-таки туговат, потому что удаляет сразу очень много ячеек,
Поэтому, я посмотрел в сторону строки+массива, и получил при удалении ячеек прирост в скорости порядка 20%:
[vba]
Код
Sub DeleteCells_Mika() Dim xRg As Range, xCell As Range Dim xAddress As String
On Error Resume Next xAddress = ActiveWindow.RangeSelection.Address Set xRg = Application.InputBox("Please select a range:", "Kutools for Excel", xAddress, , , , , 8) If xRg Is Nothing Then Exit Sub
Dim str$, ll&: str = "|": ll = 1 For Each xCell In xRg If Not xCell.Font.Bold Then str = str & xCell.Address(0, 0) & "," ll = ll + Len(xCell.Address(0, 0)) + 1 If ll >= 250 Then str = Left(str, Len(str) - 1) & "|": ll = 1 End If Next
If Len(str) > 1 Then str = Left(str, Len(str) - 1) Dim aTmp: aTmp = Split(str, "|") For ll = UBound(aTmp) To 1 Step -1 Range(aTmp(ll)).Delete xlUp 'Range(aTmp(ll)).ClearContents Next ll End If