можно ли заставить работать макрос в range (a1:z100) к примеру? насущная проблема,кол-во строк в таблице 1000,макрос выполнять нужна на нескольких листах сразу,ждать приходится минут 5 гдето ....
можно ли заставить работать макрос в range (a1:z100) к примеру? насущная проблема,кол-во строк в таблице 1000,макрос выполнять нужна на нескольких листах сразу,ждать приходится минут 5 гдето ....lamak58
Sub VSE() Dim t As Range Dim r As Range Dim rgn As Range Set t = Range("a1:k10") With t 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 <> -4142) And (r.Cells.Interior.ColorIndex <> 2) Then r.Cells.ClearContents End If Next Next End With End Sub
[/vba]
попробовал,у меня видимо не работает [vba]
Код
Sub VSE() Dim t As Range Dim r As Range Dim rgn As Range Set t = Range("a1:k10") With t 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 <> -4142) And (r.Cells.Interior.ColorIndex <> 2) Then r.Cells.ClearContents End If Next Next End With End Sub
Sub VSE() Dim r As Range Dim rgn As Range For Each sh In ActiveWorkbook.Sheets Set rgn = sh.Range("a1:k10") With rgn .Cells.UnMerge .Cells.Replace What:=ChrW(8381), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _ MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False End With For Each r In rgn If (r.Interior.ColorIndex <> -4142) And (r.Interior.ColorIndex <> 2) Then r.ClearContents End If Next r Next sh End Sub
[/vba]
lamak58, а так? [vba]
Код
Sub VSE() Dim r As Range Dim rgn As Range For Each sh In ActiveWorkbook.Sheets Set rgn = sh.Range("a1:k10") With rgn .Cells.UnMerge .Cells.Replace What:=ChrW(8381), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, _ MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False End With For Each r In rgn If (r.Interior.ColorIndex <> -4142) And (r.Interior.ColorIndex <> 2) Then r.ClearContents End If Next r Next sh End Sub