Anzeige
Archiv - Navigation
1104to1108
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

@Tino, Kommentierung von Deinem Beispiel

@Tino, Kommentierung von Deinem Beispiel
Deinem
Hallo Tino,
ist die Kommentierung von Deinem Code so einigermassen zutreffend ? Habe mal versucht es soweit wie möglich zu machen. Es war Dein Beispiel mit den Gruppieren von Datensätzen.
DU darfst gerne noch ergänzen, wenn was fehlt, sonst weiss ich in ein paar Wochen nicht mehr, was da genmacht wird.
PS: vielleicht noch eine Frage : kann ich die betroffenen datensätze (mit gleichem Kriterium in V) irgend wie farblich (font) markieren, damit ich nachher noch sehen kann, welche Datensätze vom zusammenfassen betroffen waren.
Das wäre aber nur noch ein Guddi, ist nicht notwendig.
Danke
<pre>Sub Aufbereiten4()
Dim Bereich As Range
Dim LRow As Long, A As Long, B As Long, varRow
Dim meAR1, meAR2, meAr3, meAr4, meAr5
Dim iCalc As Integer
Dim LenZ As Integer
'hier Trennzeichen angeben
Const TrennZeichen As String = " ### "
LenZ = Len(TrennZeichen)
With Application
iCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
With Sheets("Datenseite") 'Tabellennamen anpassen
' prüfen ob Daten ab Zeile 11 vorhanden sind
If .Cells(.Rows.Count, 22).End(xlUp).Row > 10 Then
' verweis auf letzte Spalte in Tabelle (Hilfsspalte)
' unter xl2007 = Spalte 256, ab xl2007 = Spalte 16384
With .Range("V10", .Cells(.Rows.Count, 22).End(xlUp)).Offset(0, .Columns.Count - 22)
meAR2 = .Offset(0, -(.Column - 22))
meAr3 = .Offset(0, -(.Column - 22))
meAR1 = .Offset(0, -(.Column - 4)) 'Spalte D = 4
meAr4 = .Offset(0, -(.Column - 3)) 'Spalte C = 3
meAr5 = .Offset(0, -(.Column - 21)) 'Spalte U = 21
' hier werden die Texte zusammengefasst,
For A = 1 To UBound(meAR1)
meAR1(A, 1) = TrennZeichen & meAR1(A, 1) & TrennZeichen
meAr4(A, 1) = TrennZeichen & meAr4(A, 1) & TrennZeichen
meAr5(A, 1) = TrennZeichen & meAr5(A, 1) & TrennZeichen
' ist in Sp. V ein X oder ist diese leer?
If meAR2(A, 1) <> "" And meAR2(A, 1) <> "S" Then
B = A 'Hilfszähler
varRow = Application.Match(meAR2(A, 1), meAr3, 0)
Do While IsNumeric(varRow)
If meAR2(varRow, 1) <> "" And meAR2(varRow, 1) <> "S" Then
If B > A Then
If InStr(meAR1(A, 1), TrennZeichen & meAR1(varRow, 1) & TrennZeichen) = 0 Then
meAR1(A, 1) = meAR1(A, 1) & meAR1(varRow, 1) & TrennZeichen
End If
If InStr(meAr4(A, 1), TrennZeichen & meAr4(varRow, 1) & TrennZeichen) = 0 Then
meAr4(A, 1) = meAr4(A, 1) & meAr4(varRow, 1) & TrennZeichen
End If
If InStr(meAr5(A, 1), TrennZeichen & meAr5(varRow, 1) & TrennZeichen) = 0 Then
meAr5(A, 1) = meAr5(A, 1) & meAr5(varRow, 1) & TrennZeichen
End If
End If
End If
' was anderes schreiben damit wert nicht zweimal gefunden wird
meAr3(varRow, 1) = "@@@@@"
' Suche weiter in Liste
varRow = Application.Match(meAR2(A, 1), meAr3, 0)
B = B + 1 'Hilfszähler ein hoch
Loop
End If
If Right$(meAR1(A, 1), LenZ) = TrennZeichen Then meAR1(A, 1) = Left$(meAR1(A, 1), Len(meAR1(A, 1)) - LenZ)
If Left$(meAR1(A, 1), LenZ) = TrennZeichen Then meAR1(A, 1) = Right$(meAR1(A, 1), Len(meAR1(A, 1)) - LenZ)
If Right$(meAr4(A, 1), LenZ) = TrennZeichen Then meAr4(A, 1) = Left$(meAr4(A, 1), Len(meAr4(A, 1)) - LenZ)
If Left$(meAr4(A, 1), LenZ) = TrennZeichen Then meAr4(A, 1) = Right$(meAr4(A, 1), Len(meAr4(A, 1)) - LenZ)
If Right$(meAr5(A, 1), LenZ) = TrennZeichen Then meAr5(A, 1) = Left$(meAr5(A, 1), Len(meAr5(A, 1)) - LenZ)
If Left$(meAr5(A, 1), LenZ) = TrennZeichen Then meAr5(A, 1) = Right$(meAr5(A, 1), Len(meAr5(A, 1)) - LenZ)
Next A
' Letzte Zeile?
LRow = .Rows(.Rows.Count).Row
' A summieren
.FormulaR1C1 = "=IF(OR(RC22="""",RC22=""S""),RC5,IF(COUNTIF(R10C22:RC22,RC22)=1," & _
"SUMIF(R10C22:R" & LRow & "C22,RC22,R10C5:R" & LRow & "C1),""""))"
' und zurück schreiben
.Offset(0, -(.Column - 1)).Value = .Value
' E summieren
.FormulaR1C1 = "=IF(OR(RC22="""",RC22=""S""),RC5,IF(COUNTIF(R10C22:RC22,RC22)=1," & _
"SUMIF(R10C22:R" & LRow & "C22,RC22,R10C5:R" & LRow & "C5),""""))"
' Daten zurück schreiben
.Offset(0, -(.Column - 5)).Value = .Value
.Offset(0, -(.Column - 4)) = meAR1 'Spalte D schreiben
.Offset(0, -(.Column - 3)) = meAr4 'Spalte C schreiben
.Offset(0, -(.Column - 21)) = meAr5 'Spalte U schreiben
' Formel für die Summierung der Werte
.FormulaR1C1 = "=IF(OR(COUNTIF(R10C22:RC22,RC22)=1,RC22="""",RC22=""S""),ROW(),TRUE)"
' Tebellenname Zelle, damit nicht doppelt angegeben werden muss
With Sheets(.Parent.Name)
.Range("A10", .Cells(LRow, .Columns.Count)).Sort Key1:=.Cells(10, .Columns.Count), Order1:=xlAscending, Header:=xlNo
End With
On Error Resume Next
' Zeilen löschen die das Ergebnis Wahr haben
.SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
' Hilfsspalte komplett löschen
.EntireColumn.Delete
On Error GoTo 0
End With
.Range("A:V").Columns.AutoFit
End If
End With
.Calculation = iCalc
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub</pre>

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
Soweit ich mich noch erinnere,
06.10.2009 16:24:31
Tino
Hallo,
habe ich mal noch etwas dazugeschrieben.
In der Zeile
.Offset(0, -(.Column - 22)).Interior.ColorIndex = 5
sollte die Färbung der Zellen stattfinden, kannst ja mal testen.
(habe nicht getestet, keine Testdatei mehr)
Sub Aufbereiten4()

Dim Bereich As Range
Dim LRow As Long, A As Long, B As Long, varRow
Dim meAR1, meAR2, meAr3, meAr4, meAr5
Dim iCalc As Integer
Dim LenZ As Integer

'hier Trennzeichen angeben 
Const TrennZeichen As String = " ### "
LenZ = Len(TrennZeichen)

With Application
    iCalc = .Calculation
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    
    With Sheets("Datenseite") 'Tabellennamen anpassen 
        ' prüfen ob Daten ab Zeile 11 vorhanden sind 
        If .Cells(.Rows.Count, 22).End(xlUp).Row > 10 Then
        ' verweis auf letzte Spalte in Tabelle (Hilfsspalte) 
        ' unter xl2007 = Spalte 256, ab xl2007 = Spalte 16384 
        With .Range("V10", .Cells(.Rows.Count, 22).End(xlUp)).Offset(0, .Columns.Count - 22)
            
            meAR2 = .Offset(0, -(.Column - 22)) 'Spalte V = 22 
            meAr3 = .Offset(0, -(.Column - 22)) 'Spalte V = 22 zusätzliche Hilfs Array 
            meAR1 = .Offset(0, -(.Column - 4)) 'Spalte D = 4 
            meAr4 = .Offset(0, -(.Column - 3)) 'Spalte C = 3 
            meAr5 = .Offset(0, -(.Column - 21)) 'Spalte U = 21 
            
            ' hier werden die Texte zusammengefasst, 
            For A = 1 To Ubound(meAR1)
                meAR1(A, 1) = TrennZeichen & meAR1(A, 1) & TrennZeichen
                meAr4(A, 1) = TrennZeichen & meAr4(A, 1) & TrennZeichen
                meAr5(A, 1) = TrennZeichen & meAr5(A, 1) & TrennZeichen
                ' ist in Sp. V ein S oder ist diese leer? 
                If meAR2(A, 1) <> "" And meAR2(A, 1) <> "S" Then
                    B = A 'Hilfszähler 
                     
                    'Wert aus Spalte V 
                    varRow = Application.Match(meAR2(A, 1), meAr3, 0)
                    
                    'Schleife bis keine Übereinstimmung in Spalte V 
                    Do While IsNumeric(varRow)
                        If meAR2(varRow, 1) <> "" And meAR2(varRow, 1) <> "S" Then
                        If B > A Then
                        
                        If InStr(meAR1(A, 1), TrennZeichen & meAR1(varRow, 1) & TrennZeichen) = 0 Then
                        meAR1(A, 1) = meAR1(A, 1) & meAR1(varRow, 1) & TrennZeichen
                        End If
                        
                        If InStr(meAr4(A, 1), TrennZeichen & meAr4(varRow, 1) & TrennZeichen) = 0 Then
                        meAr4(A, 1) = meAr4(A, 1) & meAr4(varRow, 1) & TrennZeichen
                        End If
                        
                        If InStr(meAr5(A, 1), TrennZeichen & meAr5(varRow, 1) & TrennZeichen) = 0 Then
                        meAr5(A, 1) = meAr5(A, 1) & meAr5(varRow, 1) & TrennZeichen
                        End If
                        
                        End If
                        End If
                        ' was anderes schreiben damit wert nicht zweimal gefunden wird 
                        meAr3(varRow, 1) = "@@@@@"
                        ' Suche weiter in Liste 
                        varRow = Application.Match(meAR2(A, 1), meAr3, 0)
                        B = B + 1 'Hilfszähler ein hoch 
                    Loop
                
                End If
                'nicht benötigte Zeichen aus String löschen 
                If Right$(meAR1(A, 1), LenZ) = TrennZeichen Then meAR1(A, 1) = Left$(meAR1(A, 1), Len(meAR1(A, 1)) - LenZ)
                If Left$(meAR1(A, 1), LenZ) = TrennZeichen Then meAR1(A, 1) = Right$(meAR1(A, 1), Len(meAR1(A, 1)) - LenZ)
                If Right$(meAr4(A, 1), LenZ) = TrennZeichen Then meAr4(A, 1) = Left$(meAr4(A, 1), Len(meAr4(A, 1)) - LenZ)
                If Left$(meAr4(A, 1), LenZ) = TrennZeichen Then meAr4(A, 1) = Right$(meAr4(A, 1), Len(meAr4(A, 1)) - LenZ)
                If Right$(meAr5(A, 1), LenZ) = TrennZeichen Then meAr5(A, 1) = Left$(meAr5(A, 1), Len(meAr5(A, 1)) - LenZ)
                If Left$(meAr5(A, 1), LenZ) = TrennZeichen Then meAr5(A, 1) = Right$(meAr5(A, 1), Len(meAr5(A, 1)) - LenZ)
            Next A
            
            ' Letzte Zeile? 
            LRow = .Rows(.Rows.Count).Row
            
            ' A summieren 
            .FormulaR1C1 = "=IF(OR(RC22="""",RC22=""S""),RC5,IF(COUNTIF(R10C22:RC22,RC22)=1," & _
            "SUMIF(R10C22:R" & LRow & "C22,RC22,R10C5:R" & LRow & "C1),""""))"
            ' und zurück schreiben 
            .Offset(0, -(.Column - 1)).Value = .Value
            
            ' E summieren 
            .FormulaR1C1 = "=IF(OR(RC22="""",RC22=""S""),RC5,IF(COUNTIF(R10C22:RC22,RC22)=1," & _
            "SUMIF(R10C22:R" & LRow & "C22,RC22,R10C5:R" & LRow & "C5),""""))"
            
            ' Daten zurück schreiben 
            .Offset(0, -(.Column - 5)).Value = .Value
            .Offset(0, -(.Column - 4)) = meAR1 'Spalte D schreiben 
            .Offset(0, -(.Column - 3)) = meAr4 'Spalte C schreiben 
            .Offset(0, -(.Column - 21)) = meAr5 'Spalte U schreiben 
            
            .Offset(0, -(.Column - 22)).Interior.ColorIndex = 5 'Spalte V färben <---------------------------------------------- 
            
            ' Formel für die Summierung der Werte 
            .FormulaR1C1 = "=IF(OR(COUNTIF(R10C22:RC22,RC22)=1,RC22="""",RC22=""S""),ROW(),TRUE)"
            
            ' Tebellenname Zelle, damit nicht doppelt angegeben werden muss 
            With Sheets(.Parent.Name)
             .Range("A10", .Cells(LRow, .Columns.Count)).Sort Key1:=.Cells(10, .Columns.Count), Order1:=xlAscending, Header:=xlNo
            End With
            
            
            On Error Resume Next
            ' Zeilen löschen die das Ergebnis Wahr haben 
            .SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
            ' Hilfsspalte komplett löschen 
            .EntireColumn.Delete
            On Error GoTo 0
        
        
        End With
        'Spalte A bis V optimale Breite einstllen 
        .Range("A:V").Columns.AutoFit
        
        End If
        
    End With
    
    .Calculation = iCalc
    .ScreenUpdating = True
    .EnableEvents = True

End With

End Sub
Gruß Tino
Anzeige
Danke Tino, ist OK :-) owT
07.10.2009 10:58:27
Joachim

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige