AW: Auszug aus mehreren Arbeitsblätten - Code ändern
26.09.2017 11:05:48
ChrisL
hi
Eine letzte Gratisprogrammierung schenke ich dir...
Sub MachNochmal()
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim WS3 As Worksheet
Dim lngLetzteZeile As Long, lngZeile As Long
Dim lngCounter As Long, strTitel As String
' Tabelle neu anlegen
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Auszug").Delete
Application.DisplayAlerts = True
On Error GoTo 0
ThisWorkbook.Worksheets("Muster").Copy After:=Sheets(Sheets.Count)
Set WS2 = ActiveSheet
WS2.Name = "Auszug"
' Rohdaten in Array einlesen
Application.ScreenUpdating = False
For Each WS1 In ThisWorkbook.Worksheets
With WS1
If .Name "Übersicht" And .Name "Muster" And .Name "Auszug" Then
lngLetzteZeile = .Cells(Rows.Count, 11).End(xlUp).Row
If lngLetzteZeile >= 20 Then
For lngZeile = 20 To lngLetzteZeile
If .Cells(lngZeile, 1) "" And _
WorksheetFunction.CountBlank(.Range(.Cells(lngZeile, 2), .Cells(lngZeile, 12))) = 11 Then
strTitel = .Cells(lngZeile, 1) & " " & .Cells(lngZeile + 1, 1)
lngZeile = lngZeile + 1
End If
If .Cells(lngZeile, 11) > 0 And Replace(.Cells(lngZeile, 12), " ", "") = "ja" Then
If lngCounter = 0 Then ReDim arrDaten(0 To 5, 0 To 0) Else _
ReDim Preserve arrDaten(0 To 5, 0 To lngCounter)
arrDaten(0, lngCounter) = strTitel
arrDaten(1, lngCounter) = .Range("H3")
arrDaten(2, lngCounter) = .Cells(lngZeile, 1)
arrDaten(3, lngCounter) = .Cells(lngZeile, 2)
arrDaten(4, lngCounter) = .Cells(lngZeile, 6)
arrDaten(5, lngCounter) = .Cells(lngZeile, 9)
lngCounter = lngCounter + 1
End If
Next lngZeile
End If
End If
End With
Next WS1
If lngCounter = 0 Then Exit Sub
' Daten zwecks Sortierung in Hilfstabelle und Hilfstabelle wieder löschen
Set WS3 = Worksheets.Add
With WS3
.Range("A1:F" & lngCounter - 1) = Application.Transpose(arrDaten)
With .Sort
.SortFields.Clear
.SortFields.Add Key:=WS3.Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
.SetRange Range("A1:F" & lngCounter - 1)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Daten zurück in Array und Tabelle wieder löschen
arrDaten = Application.Transpose(.Range("A1:F" & lngCounter - 1).Value)
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0
End With
' Ergbnis aus Array übertragen
lngCounter = 1
lngZeile = 8
With WS2
Do While lngCounter arrDaten(1, lngCounter - 1) Or _
arrDaten(2, lngCounter) arrDaten(2, lngCounter - 1) Then
.Cells(lngZeile + 1, 1) = arrDaten(1, lngCounter)
.Cells(lngZeile + 2, 1) = arrDaten(2, lngCounter)
lngZeile = lngZeile + 3
End If
End If
.Cells(lngZeile, 1) = arrDaten(3, lngCounter)
.Cells(lngZeile, 2) = arrDaten(4, lngCounter)
.Cells(lngZeile, 3) = arrDaten(5, lngCounter)
.Cells(lngZeile, 4) = arrDaten(6, lngCounter)
With .Range(.Cells(lngZeile, 1), .Cells(lngZeile, 4))
.Borders(xlEdgeLeft).Weight = xlThin
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeRight).Weight = xlThin
End With
lngZeile = lngZeile + 1
lngCounter = lngCounter + 1
Loop
End With
End Sub
cu
Chris