Sub POLIS() Call Prepare For Each sh In ActiveWorkbook.Sheets Set rgn = sh.UsedRange For Each r In rgn.Cells r.MergeCells = False r.Cells.Replace What:=ChrW(8381), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _ MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False If (r.Cells.Interior.ColorIndex <> 38) And (r.Cells.Interior.ColorIndex <> -4142) Then r.Cells.ClearContents End If Next Next Call Ended End Sub
[/vba]
вопрос - можно ли переделать его,чтобы Excel считал не по ячейкам а как массивы?а то слишком медленно выполняется данный код при больших объемах обработки.
есть вот такой код [vba]
Код
Sub POLIS() Call Prepare For Each sh In ActiveWorkbook.Sheets Set rgn = sh.UsedRange For Each r In rgn.Cells r.MergeCells = False r.Cells.Replace What:=ChrW(8381), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _ MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False If (r.Cells.Interior.ColorIndex <> 38) And (r.Cells.Interior.ColorIndex <> -4142) Then r.Cells.ClearContents End If Next Next Call Ended End Sub
[/vba]
вопрос - можно ли переделать его,чтобы Excel считал не по ячейкам а как массивы?а то слишком медленно выполняется данный код при больших объемах обработки.lamak58
Сообщение отредактировал lamak58 - Среда, 22.06.2016, 16:57
ой,извиняюсь,забыл добавить что Call Prepare , Call Ended у меня вызывают уже вот это [vba]
Код
Public Sub Prepare() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False ActiveSheet.DisplayPageBreaks = False Application.DisplayStatusBar = False Application.DisplayAlerts = False Dim r As Range Dim rgn As Range End Sub Public Sub Ended() Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True ActiveSheet.DisplayPageBreaks = True Application.DisplayStatusBar = True Application.DisplayAlerts = True End Sub
[/vba]
ой,извиняюсь,забыл добавить что Call Prepare , Call Ended у меня вызывают уже вот это [vba]
Код
Public Sub Prepare() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False ActiveSheet.DisplayPageBreaks = False Application.DisplayStatusBar = False Application.DisplayAlerts = False Dim r As Range Dim rgn As Range End Sub Public Sub Ended() Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True ActiveSheet.DisplayPageBreaks = True Application.DisplayStatusBar = True Application.DisplayAlerts = True End Sub
lamak58, вот так попробуйте: поиск и замену не обязательно в каждой ячейке отдельно делать, можно сразу на всем листе. С объединенными ячейками тоже. [vba]
Код
Sub POLIS() Call Prepare 'For Each sh In ActiveWorkbook.Sheets Set rgn = sh.UsedRange rgn.Cells.UnMerge rgn.Cells.Replace What:=ChrW(8381), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _ MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False For Each r In rgn.Cells If (r.Cells.Interior.ColorIndex <> 38) And (r.Cells.Interior.ColorIndex <> -4142) Then r.Cells.ClearContents End If Next 'Next Call Ended End Sub
[/vba]
lamak58, вот так попробуйте: поиск и замену не обязательно в каждой ячейке отдельно делать, можно сразу на всем листе. С объединенными ячейками тоже. [vba]
Код
Sub POLIS() Call Prepare 'For Each sh In ActiveWorkbook.Sheets Set rgn = sh.UsedRange rgn.Cells.UnMerge rgn.Cells.Replace What:=ChrW(8381), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _ MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False For Each r In rgn.Cells If (r.Cells.Interior.ColorIndex <> 38) And (r.Cells.Interior.ColorIndex <> -4142) Then r.Cells.ClearContents End If Next 'Next Call Ended End Sub
With Application.FindFormat .Clear .Interior.Color = 65535 ' желтый End With
For Each sh In ActiveWorkbook.Sheets With sh.UsedRange .MergeCells = False .Replace What:=ChrW(8381), Replacement:="", LookAt:=xlPart Set r = .Find("*", SearchFormat:=True) If Not r Is Nothing Then Do r.ClearContents Set r = .Find("*", after:=r, SearchFormat:=True) Loop While Not r Is Nothing End If End With Next sh Application.FindFormat.Clear End Sub
[/vba]
почти так же, но раз уж нарисовал: [vba]
Код
Sub ertert() Dim sh As Worksheet, r As Range
With Application.FindFormat .Clear .Interior.Color = 65535 ' желтый End With
For Each sh In ActiveWorkbook.Sheets With sh.UsedRange .MergeCells = False .Replace What:=ChrW(8381), Replacement:="", LookAt:=xlPart Set r = .Find("*", SearchFormat:=True) If Not r Is Nothing Then Do r.ClearContents Set r = .Find("*", after:=r, SearchFormat:=True) Loop While Not r Is Nothing End If End With Next sh Application.FindFormat.Clear End Sub
lamak58, вот так попробуйте: поиск и замену не обязательно в каждой ячейке отдельно делать, можно сразу на всем листе. С объединенными ячейками тоже.
вау,просто заменил полторы строчки,и работа ускорилась в разы,огромное спасибо :o
upd.хм, насчет выводов я поспешил.на приложенном файле попробовал две версии кода, [vba]
Код
Sub POLIS2() Call Prepare For Each sh In ActiveWorkbook.Sheets Set rgn = sh.UsedRange For Each r In rgn.Cells r.MergeCells = False r.Cells.Replace What:=ChrW(8381), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _ MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False If (r.Cells.Interior.ColorIndex <> 38) And (r.Cells.Interior.ColorIndex <> -4142) Then r.Cells.ClearContents End If Next Next Call Ended End Sub
[/vba]
и
[vba]
Код
Sub POLIS() Call Prepare For Each sh In ActiveWorkbook.Sheets Set rgn = sh.UsedRange For Each r In rgn.Cells rgn.Cells.UnMerge rgn.Cells.Replace What:=ChrW(8381), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _ MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False If (r.Cells.Interior.ColorIndex <> 38) And (r.Cells.Interior.ColorIndex <> -4142) Then r.Cells.ClearContents End If Next Next Call Ended End Sub
[/vba]
POLIS 2 оказался быстрее ,ничего не понимаю.... %) [moder]У меня пишет, что архив поврежден или имеет неизвестный формат.[/moder]
lamak58, вот так попробуйте: поиск и замену не обязательно в каждой ячейке отдельно делать, можно сразу на всем листе. С объединенными ячейками тоже.
вау,просто заменил полторы строчки,и работа ускорилась в разы,огромное спасибо :o
upd.хм, насчет выводов я поспешил.на приложенном файле попробовал две версии кода, [vba]
Код
Sub POLIS2() Call Prepare For Each sh In ActiveWorkbook.Sheets Set rgn = sh.UsedRange For Each r In rgn.Cells r.MergeCells = False r.Cells.Replace What:=ChrW(8381), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _ MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False If (r.Cells.Interior.ColorIndex <> 38) And (r.Cells.Interior.ColorIndex <> -4142) Then r.Cells.ClearContents End If Next Next Call Ended End Sub
[/vba]
и
[vba]
Код
Sub POLIS() Call Prepare For Each sh In ActiveWorkbook.Sheets Set rgn = sh.UsedRange For Each r In rgn.Cells rgn.Cells.UnMerge rgn.Cells.Replace What:=ChrW(8381), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _ MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False If (r.Cells.Interior.ColorIndex <> 38) And (r.Cells.Interior.ColorIndex <> -4142) Then r.Cells.ClearContents End If Next Next Call Ended End Sub
[/vba]
POLIS 2 оказался быстрее ,ничего не понимаю.... %) [moder]У меня пишет, что архив поврежден или имеет неизвестный формат.[/moder]lamak58