|
Hab das ganze jetz so. Funktionerit prima und schnell.
Sub Tabelle_075_dbl()
'
' erstellt Tabelle mit 0,75 dbl und überprüft ob schon vorhanden
'
'
Dim sh As Worksheet
Dim rngBerich As Range
Dim rangLeereZellen As Range
Dim lngZeileMax As Long
If Not shExists("0,75 dbl") Then
Worksheets("Vorlage").Copy Before:=Worksheets(1)
Set sh = Worksheets(1)
sh.Name = "0,75 dbl"
Else
MsgBox "Tabelle 0,75 dbl existiert bereits", 48
Exit Sub
End If
sh.Range("A1").Value = "0,75_dbl_Lapp"
With Sheets("Drahtsatz kopieren")
.Range("$A$2:$M$200").AutoFilter Field:=4, Criteria1:="DBU"
.Range("$A$2:$M$200").AutoFilter Field:=5, Criteria1:="0,75"
.Range("F:F").Copy Sheets("0,75 dbl").Range("C8")
.Range("I:I").Copy Sheets("0,75 dbl").Range("M8")
.Range("J:J").Copy Sheets("0,75 dbl").Range("S8")
sh.Range("8:8,9:9").Delete
sh.Range("A1").Select
If .AutoFilterMode Then If .FilterMode Then .ShowAllData
.Select
Range("A1").Select
End With
With sh
lngZeileMax = .Range("C" & .Rows.Count).End(xlUp).Row
Set rngBereich = .Range("C8:C5000" & lngZeileMax)
Set rngLeereZellen = rngBereich.SpecialCells(xlCellTypeBlanks)
rngLeereZellen.EntireRow.Delete
End With
MsgBox "Tabelle 0,75 dbl wurde erstellt", 64
End Sub
|