Hallo Werner,
hier der (ganze) Code:
Sub Zusammenfassung()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim iZeile As Long, tempZeile As Long, iZähler As Long
Dim strMark As String
Set WS1 = Worksheets("Fragen (BL4)")
Set WS2 = Worksheets("Zusammenfassung (BL2)")
Application.ScreenUpdating = False
For iZeile = WS1.Cells(WS1.Rows.Count, 9).End(xlUp).Row To 9 Step -1
If IsNumeric(WS1.Cells(iZeile, 9)) And WS1.Cells(iZeile, 9) "" And _
WorksheetFunction.CountIf(WS2.Columns(1), WS1.Cells(iZeile, 1)) = 0 And _
Left(WS1.Cells(iZeile, 1), 4) "Punk" And _
Left(WS1.Cells(iZeile, 1), 4) "Erfü" Then
iZähler = iZähler + 1
Select Case WS1.Cells(iZeile, 9)
'Case 10: strMark = "Positive Bemerkungen"
Case 8: strMark = "Hinweise / Verbesserungsvorschläge:"
Case 6: strMark = "Nebenabweichungen:"
Case 4: strMark = "Hauptabweichungen:"
Case 0: strMark = "Hauptabweichungen:"
Case Else: strMark = ""
End Select
If strMark "" Then
tempZeile = Application.Match(strMark, WS2.Columns(3), 0) + 1
WS2.Rows(tempZeile).Insert Shift:=xlDown
WS2.Cells(tempZeile, 1) = WS1.Cells(iZeile, 1)
WS2.Cells(tempZeile, 3) = WS1.Cells(iZeile, 11)
Call sortieren
Call ZeileFormatieren(tempZeile, WS2)
End If
End If
Next iZeile
End Sub
Sub sortieren()
Dim anfang1 As Long
Dim ende1 As Long
Dim anfang2 As Long
Dim ende2 As Long
Dim anfang3 As Long
Dim ende3 As Long
Dim anfang4 As Long
Dim ende4 As Long
Dim block1 As Range
Dim block2 As Range
Dim block3 As Range
Dim block4 As Range
Dim bereich1 As Range
Dim test As Range
With Sheets("Zusammenfassung (BL2)")
'**** Ermittelt den Bereich block1 ****
anfang1 = .Range("A6").End(xlDown).Row
If .Cells(anfang1 + 1, 1) = "" Then
ende1 = anfang1 + 1
Else
ende1 = .Range("A" & anfang1).End(xlDown).Row
Set block1 = Sheets("Zusammenfassung (BL2)").Range("A" & anfang1 & ":Q" & ende1)
End If
'**** Ermittelt den Bereich block2 ****
anfang2 = .Range("A" & ende1).End(xlDown).Row
If .Cells(anfang2 + 1, 1) = "" Then
ende2 = anfang2 + 1
Else
ende2 = .Range("A" & anfang2).End(xlDown).Row
Set block2 = Sheets("Zusammenfassung (BL2)").Range("A" & anfang2 & ":Q" & ende2)
End If
'**** Ermittelt den Bereich block3 ****
anfang3 = .Range("A" & ende2).End(xlDown).Row
If .Cells(anfang3 + 1, 1) = "" Then
ende3 = anfang3 + 1
Else
ende3 = .Range("A" & anfang3).End(xlDown).Row
Set block3 = Sheets("Zusammenfassung (BL2)").Range("A" & anfang3 & ":Q" & ende3)
End If
'**** Ermittelt den Bereich block4 ****
anfang4 = .Range("A" & ende3).End(xlDown).Row
If .Cells(anfang4 + 1, 1) = "" Then
ende4 = anfang4 + 1
Else
ende4 = .Range("A" & anfang4).End(xlDown).Row
Set block4 = Sheets("Zusammenfassung (BL2)").Range("A" & anfang4 & ":Q" & ende4)
End If
If Not block1 Is Nothing Then
If block1.Rows.Count > 2 Then
'*** sortieren ***
Worksheets("Zusammenfassung (BL2)").Sort.SortFields.Clear
Worksheets("Zusammenfassung (BL2)").Sort.SortFields.Add _
Key:=Range("A" & anfang1 & ":A" & ende1), SortOn:=xlSortOnValues, Order:= _
xlAscending, _
CustomOrder:= _
"1.1,1.2,1.3,1.4,1.5,2.1,2.2,2.3,2.4,2.5,3.1,3.2,3.3,3.4,3.5,3.6,4.1,4.2,4.3,4.4,4. _
5,5.1,5.2,5.3,5.4,5.5,5.6,5.7,5.8,5.9,5.10,5.11,6.1,6.2,6.3,6.4,6.5,6.6,7.1,7.2,7.3,7.4,7.5,7.6,7.7,8.1,8.2,8.3,9.1,9.2,10.1,10.2,10.3,11.1,11.2" _
, DataOption:=xlSortTextAsNumbers
With Worksheets("Zusammenfassung (BL2)").Sort
.SetRange Range(block1.Address)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If
End If
If Not block2 Is Nothing Then
If block2.Rows.Count > 2 Then
'*** sortieren ***
Worksheets("Zusammenfassung (BL2)").Sort.SortFields.Clear
Worksheets("Zusammenfassung (BL2)").Sort.SortFields.Add _
Key:=Range("A" & anfang2 & ":A" & ende2), SortOn:=xlSortOnValues, Order:= _
xlAscending, _
CustomOrder:= _
"1.1,1.2,1.3,1.4,1.5,2.1,2.2,2.3,2.4,2.5,3.1,3.2,3.3,3.4,3.5,3.6,4.1,4.2,4.3,4.4,4. _
5,5.1,5.2,5.3,5.4,5.5,5.6,5.7,5.8,5.9,5.10,5.11,6.1,6.2,6.3,6.4,6.5,6.6,7.1,7.2,7.3,7.4,7.5,7.6,7.7,8.1,8.2,8.3,9.1,9.2,10.1,10.2,10.3,11.1,11.2" _
, DataOption:=xlSortTextAsNumbers
With Worksheets("Zusammenfassung (BL2)").Sort
.SetRange Range(block2.Address)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If
End If
If Not block3 Is Nothing Then
If block3.Rows.Count > 2 Then
'*** sortieren ***
Worksheets("Zusammenfassung (BL2)").Sort.SortFields.Clear
Worksheets("Zusammenfassung (BL2)").Sort.SortFields.Add _
Key:=Range("A" & anfang3 & ":A" & ende3), SortOn:=xlSortOnValues, Order:= _
xlAscending, _
CustomOrder:= _
"1.1,1.2,1.3,1.4,1.5,2.1,2.2,2.3,2.4,2.5,3.1,3.2,3.3,3.4,3.5,3.6,4.1,4.2,4.3,4. _
4,4.5,5.1,5.2,5.3,5.4,5.5,5.6,5.7,5.8,5.9,5.10,5.11,6.1,6.2,6.3,6.4,6.5,6.6,7.1,7.2,7.3,7.4,7.5,7.6,7.7,8.1,8.2,8.3,9.1,9.2,10.1,10.2,10.3,11.1,11.2" _
, DataOption:=xlSortTextAsNumbers
With Worksheets("Zusammenfassung (BL2)").Sort
.SetRange Range(block3.Address)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If
End If
If Not block4 Is Nothing Then
If block4.Rows.Count > 2 Then
'*** sortieren ***
Worksheets("Zusammenfassung (BL2)").Sort.SortFields.Clear
Worksheets("Zusammenfassung (BL2)").Sort.SortFields.Add _
Key:=Range("A" & anfang4 & ":A" & ende4), SortOn:=xlSortOnValues, Order:= _
xlAscending, _
CustomOrder:= _
"1.1,1.2,1.3,1.4,1.5,2.1,2.2,2.3,2.4,2.5,3.1,3.2,3.3,3.4,3.5,3.6,4.1,4.2,4.3,4. _
4,4.5,5.1,5.2,5.3,5.4,5.5,5.6,5.7,5.8,5.9,5.10,5.11,6.1,6.2,6.3,6.4,6.5,6.6,7.1,7.2,7.3,7.4,7.5,7.6,7.7,8.1,8.2,8.3,9.1,9.2,10.1,10.2,10.3,11.1,11.2" _
, DataOption:=xlSortTextAsNumbers
With Worksheets("Zusammenfassung (BL2)").Sort
.SetRange Range(block4.Address)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If
End If
End With
End Sub
Private Sub ZeileFormatieren(Zeile As Long, ws As Worksheet)
'Breite der verbundenen Zellen bestimmen
Dim Breite As Long
Dim BreiteG As Long
Dim SP As Long
For SP = 1 To 17
Breite = Columns(SP).ColumnWidth
BreiteG = BreiteG + Breite
Next SP
Columns("C:C").ColumnWidth = BreiteG
ws.Range(ws.Cells(Zeile, 1), ws.Cells(Zeile, 2)).Merge
'WS.Range(WS.Cells(Zeile, 3), WS.Cells(Zeile, 17)).Merge
With ws.Range(ws.Cells(Zeile, 1), ws.Cells(Zeile, 17))
.Interior.Pattern = xlNone
.Font.Bold = False
.Font.Size = 10
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.WrapText = True
'.Rows.EntireRow.AutoFit
.Columns("C:C").ColumnWidth = BreiteG 'vorher fixer Wert von 55
.Rows.EntireRow.AutoFit
.Columns("C:C").ColumnWidth = 5
ws.Range(ws.Cells(Zeile, 3), ws.Cells(Zeile, 17)).Merge
End With
End Sub
Und danke für alles Werner!
Lg