Macro ändern (zum 2. leider-> Heiko S.?)
17.03.2006 23:43:25
Rene
Kannst du (Heiko S.) aber auch die anderen mir bitte sagen wie ich bei deinem Code noch zwei Spalten einfügen kann?
Ich wollte gerne deinen Code um zwei Spalten erweitern.Also der Copy Bereich würde jetzt bis G gehen. Dieses konnte ich auch noch so halbwegs verfolgen nur dann wenn es die Spalten dreht fügt es mir nicht die neuen Spalten mit ein.Wie es dann in zB. "I2" eingetragen wird habe ich auch rausbekommen. Aber eben der entscheidende Rest fehlt mir noch.Kannst du oder jemand anders mir bitte noch mal weiterhelfen?
Hier noch mal der letzte Code:
Sub Auswerten4()
Dim strTeam As String, strSheetName As String, strStartSheet As String
Dim lngLastRow As Long, lngI As Long, lngN As Long, lngTeamErsteZeile As Long
Dim intTeamCounter As Integer, intSpalte As Integer, intAusW As Integer
' Programm starten wenn die Ausgangstabelle auch das aktive Tabellenblatt ist !!!
strStartSheet = ActiveSheet.Name
ActiveSheet.UsedRange.Copy
ActiveWorkbook.Worksheets.Add After:=Sheets(Sheets.Count)
strSheetName = ActiveSheet.Name
ActiveSheet.Paste Destination:=ActiveSheet.Range("A1")
lngTeamErsteZeile = 2
Application.ScreenUpdating = False
With Worksheets(strSheetName)
lngLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
.Range(Cells(1, 1), Cells(lngLastRow, 5)).Sort _
Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
lngN = lngLastRow + 5
strTeam = UCase(.Cells(2, 1))
For lngI = 3 To lngLastRow + 1
If strTeam <> UCase(.Cells(lngI, 1)) Then
.Range(Cells(lngTeamErsteZeile, 1), Cells(lngI - 1, 5)).Sort _
Key1:=Range("E" & lngTeamErsteZeile), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
.Cells(lngN, 1) = .Cells(lngI - 1, 1)
intSpalte = 2
If lngI - lngTeamErsteZeile < 4 Then
intAusW = lngI - lngTeamErsteZeile - 1
Else
intAusW = 3
End If
For intTeamCounter = lngTeamErsteZeile To lngTeamErsteZeile + intAusW
.Range(Cells(intTeamCounter, 2), Cells(intTeamCounter, 5)).Copy _
Destination:=.Cells(lngN, intSpalte)
intSpalte = intSpalte + 4
Next intTeamCounter
lngN = lngN + 1
lngTeamErsteZeile = lngI
End If
strTeam = UCase(.Cells(lngI, 1))
Next lngI
Rows("1:" & lngLastRow + 4).Delete
.UsedRange.Copy Destination:=Worksheets(strStartSheet).Range("H1")
Application.DisplayAlerts = False
Worksheets(strSheetName).Delete
Worksheets(strStartSheet).Activate
End With
With Application
.ScreenUpdating = True
.CutCopyMode = False
.DisplayAlerts = True
End With
End Sub