LOL - wenigstens zeigt der Link, wo eine vernünftige Vorlage
Step 1 - wozu ein Makro, wenn es ein Mausklick auch regelt?
Step 2 - ohne die Vorlage hättest du jetzt x Makro-Vorschläge zum Verschrotten deine Mappe
Step 3 - was soll ein Programmierer mit so einem Chaos?
Bereinige erst einmal, was du nicht benötigst. Wie überhaupt, sollte man(n) erst mit Code-Texten
beginnen, wenn die Vorlage in sich schlüssig und fertig.
Wie Werner schon in anderen Beiträgen explizit erläutert, vermeide solche verbundenen Zellen, u.a.
Dennoch als Momentaufnahme, den zwischenzeitlich hattu ja sicher schon x-mal umgebaut!
Option Explicit
Sub Step2_Prüfe_Lösche()
Dim oWsh As Worksheet, Sh As Worksheet
'das mit dem Filter lassen wir einmal
Application.DisplayAlerts = False
Set oWsh = Sheets("Temp")
For Each Sh In ThisWorkbook.Sheets
If Sh.Name <> oWsh.Name Then
If Sh.Visible = -1 Then
If Not oWsh.Columns(4).Cells.Find(Sh.Name, LookIn:=xlValues) Is Nothing Then
If MsgBox("Arbeitsblatt: " & Sh.Name & " löschen?", vbQuestion + vbYesNo) = vbYes Then Sh.Delete
End If
End If
End If
Next Sh
Application.DisplayAlerts = False
End Sub
Sub Step3_AutoFilterCopy()
Dim wSh As Worksheet, wSto As Worksheet
Dim strFiltered As Variant, ShIndex As Variant
Dim Rng As Range
Dim arrF() As Variant, x
Set wSh = ActiveSheet
strFiltered = FilterProper(wSh, 4)
If Len(strFiltered) Then
ShIndex = FilteredSheet(strFiltered)
If ShIndex = 0 Then Exit Sub
End If
Set wSto = Sheets(ShIndex)
Set Rng = ClearToDo(wSto)
If Rng Is Nothing Then Exit Sub
On Error GoTo errh
arrF = MakeArea(wSh, strFiltered)
With wSto
For x = LBound(arrF, 1) To UBound(arrF, 1)
Rng.Offset(x).Value = arrF(x, 1)
Rng.Offset(x, 1).Value = arrF(x, 2)
Rng.Offset(x, 8).Value = arrF(x, 3)
Rng.Offset(x, 9).Value = arrF(x, 4)
Rng.Offset(x, 10).Value = arrF(x, 5)
Rng.Offset(x, 11).Value = arrF(x, 6)
Next x
End With
On Error GoTo 0
errh:
End Sub
Private Function MakeArea(Sh As Worksheet, ToDo As Variant) As Variant
Dim RngF As Range, RngA As Range, RngR As Range
Dim rwCnt As Long
Dim arrTo() As Variant, x
With Sh
Set RngF = .AutoFilter.Range
Set RngF = RngF.SpecialCells(xlCellTypeVisible)
For Each RngA In RngF.Areas
For Each RngR In RngA.Rows
rwCnt = rwCnt + 1
Next RngR
Next RngA
ReDim arrTo(1 To rwCnt - 1, 6)
For Each RngA In RngF.Areas
For Each RngR In RngA.Rows
If RngR.Row <> 1 Then
x = x + 1
arrTo(x, 1) = RngR.Cells(3).Value
arrTo(x, 2) = RngR.Cells(5).Value
arrTo(x, 3) = RngR.Cells(1).Value
arrTo(x, 4) = RngR.Cells(2).Value
arrTo(x, 5) = RngR.Cells(6).Value
arrTo(x, 6) = RngR.Cells(7).Value
End If
Next RngR
Next RngA
End With
MakeArea = arrTo
End Function
Private Function ClearToDo(Sh As Worksheet) As Range
Dim Cfirst As Range, Cend As Range
On Error Resume Next
With Sh
Set Cfirst = .Cells.Find("Artikelnummer", LookIn:=xlValues)
Set Cend = Cfirst.CurrentRegion
If Cend.Rows.Count > 1 Then
Set Cend = Cend.Offset(1).Resize(Cend.Rows.Count - 1)
Cend.ClearContents
End If
Set ClearToDo = Cfirst
End With
On Error GoTo 0
End Function
Private Function FilteredSheet(ToDo As Variant) As Variant
Dim ws As Worksheet
FilteredSheet = 0
For Each ws In Sheets
If ws.Name = ToDo Then FilteredSheet = ws.Index
Next ws
End Function
Private Function FilterProper(Sh As Worksheet, fItem As Long) As Variant
With Sh
If .AutoFilterMode Then
If .AutoFilter.Range.Address = .UsedRange.Address Then
With .AutoFilter
If .Filters(fItem).On Then
With .Filters(fItem)
If .Operator = 0 Then FilterProper = Mid(.Criteria1, 2)
End With
End If
End With
End If
End If
End With
End Function
|