ich würde gerne u.a. Coding optimieren, indem die jeweiligen Bereiche "Hauptabweichung", "Nebenabweichung" und "Hinweise / Verbesserungsvorschläge" getrennt voneinander immer nach Spalte A sortiert werden - hier ist weiters zu beachten, dass das Format der zu sortierenden Nummern wie folgt aussieht:
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
Wenn ich nämlich eine Zeile lösche, dann wird beim erneuten Aufruf des Makros "Zusammenfassung" der fehlende Eintrag im entsprechenden Bereich immer ganz oben eingefügt - siehe Bild:
Anbei das Coding:
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 ZeileFormatieren(tempZeile, WS2)
End If
End If
Next iZeile
End Sub
Private Sub ZeileFormatieren(Zeile As Long, WS As Worksheet)
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 = 55
.Rows.EntireRow.AutoFit
.Columns("C:C").ColumnWidth = 5
WS.Range(WS.Cells(Zeile, 3), WS.Cells(Zeile, 17)).Merge
End With
End Sub
So - ich hoffe Ihr versteht was ich gerne machen möchte ;-)
Besten Dank im Voraus für Eure professionelle Unterstützung!!!
Lg,
Chrisi