Makro über mehrere Sheets
21.10.2021 16:19:05
Chris
ich möchte unten stehendes Makro über mehrere Sheets laufen lassen und bekommt die Meldung "Select-Methode kann nicht ausgeführt werden".
Ersetze ich "ws." durch "ActiveSheet" funktioniert es, aber nur wenn ein Sheet aktiv ist.
Was muss ich ändern, damit das Makro automatisch über alle Sheets, außder dem Sheet "Test" läuft?
GRuß
Chris
Sub LinesShades()
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim lngLR As Long
Dim lngLC As Long
Dim ws As Worksheet
For Each ws In Sheets
If ws.Name "Test" Then
lngLR = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
lngLC = ws.Cells(2, Columns.Count).End(xlToLeft).Column
'Rahmen entfernen
ws.Cells.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
'Variablen Rahmen setzen
With ws
.Range(.Cells(1, 5), .Cells(1, lngLC)).Merge
.Cells(1, 5).Value = "Bestellung " & ws.Name
.Cells(1, 5).HorizontalAlignment = xlCenter
.UsedRange.HorizontalAlignment = xlCenter
End With
lngzelle = ws.Range("E:E").Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlPrevious).Row
lngspa = Sheets(1).Cells(2, Columns.Count).End(xlToLeft).Address
ws.Range("E1:" & lngspa).Resize(lngzelle, lngLC - 4).Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
ws.Range("J2:J" & lngzelle).Select
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
ws.Range("M2:N" & lngzelle).Select
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
ws.Range("K2:N2").Select
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThick
End With
ws.Range("K" & lngzelle & ":" & "N" & lngzelle).Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThick
End With
ws.Range("E2:N2").Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThick
End With
ws.Range("M2:M" & lngzelle).Select
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
'Farbbalken löschen
lngzelle = ActiveSheet.Range("E:E").Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlPrevious).Row
ws.Range("E1:J" & lngzelle).Interior.Color = xlNone
ws.Range("N1:M" & lngzelle).Interior.Color = xlNone '
'...neu setzen
For i = 4 To lngzelle Step 2
ws.Cells(i, 1).Offset(, 4).Resize(, 6).Interior.Color = RGB(217, 217, 217)
ws.Cells(i, 1).Offset(, 13).Interior.Color = RGB(217, 217, 217)
Next
For ii = 3 To lngzelle
If ws.Cells(ii, 11).Value = "" Then
ws.Cells(ii, 11).Resize(1, 2).Value = "--"
ws.Cells(ii, 11).Interior.ColorIndex = xlNone
ws.Cells(ii, 11).NumberFormat = "@"
End If
ws.Range("E2").Interior.Color = RGB(255, 217, 102) 'RGB(255, 230, 153)
ws.Range("H2").Interior.Color = RGB(255, 217, 102) 'RGB(255, 230, 153)
ws.Range("K2:M2").Interior.Color = RGB(255, 217, 102)
Next
Application.ScreenUpdating = True
ws.Columns.AutoFit
ws.Rows.AutoFit
Application.EnableEvents = True
End If
Next
End Sub