Microsoft Excel

Excel und VBA: Beitrag aus Herbers Excel-Forumsarchiv

Verdichtung einer Tabelle

    Betrifft: Verdichtung einer Tabelle
    von: Bluebeagle
    Geschrieben am: 23.07.2003 12:13:27

    Hi an die netten Helfer,

    folgendes VBA-Skript (Original von Nike, danke nochmal) soll eine Excel-Tabelle komprimieren um mehrfach Informationen zu löschen.
    In der Ausgangstabelle existiert pro Attribut (Att1....Att3) und ID jeweils eine Zeile. In der komprimierten Tabelle soll dann nur noch eine Zeile pro ID vorhanden sein und die Attribute nebeneinander gelistet werden, sofern vorhanden. Überzählige Zeilen werden gelöscht.
    Soweit so gut, die überflüssigen Zeilen werden gelöscht, aber die Spalten mit Attributen werden komplett gefüllt/markiert und nicht nur dort wo das entsprechende Attribut auch wirklich vorhanden wahr.
    Meine Frage nun was habe ich falsch gemacht? Ich sehe wahrscheinlich den Wald vor lauter Bäumen nicht.

    Vielen Dank für Eure Hilfe im voraus und ich hoffe dass ich bald in der Lage bin auch zu helfen und nicht nur Hilfe zu empfangen.

    Gruss
    bluebeagle

    Sub reduceDB()
    Dim lngRow As Long
    
        For lngRow = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
            If Cells(lngRow, 1) = strLand And _
                Cells(lngRow, 2) = strFirma And _
                Cells(lngRow, 3) = strName And _
                Cells(lngRow, 4) = strID Then
                
                If Cells(lngRow, 6) <> "" Then
                    strAtt1 = Cells(lngRow, 6)
                End If
                If Cells(lngRow, 7) <> "" Then
                    strAtt2 = Cells(lngRow, 7)
                End If
                If Cells(lngRow, 8) <> "" Then
                    strAtt3 = Cells(lngRow, 8)
                End If
                Rows(lngRow + 1).Delete
            Else
                strLand = Cells(lngRow, 1)
                strFirma = Cells(lngRow, 2)
                strName = Cells(lngRow, 3)
                strID = Cells(lngRow, 4)
                If lngRow <> Cells(Rows.Count, 1).End(xlUp).Row Then
                    Cells(lngRow + 1, 6) = strAtt1
                    Cells(lngRow + 1, 7) = strAtt2
                    Cells(lngRow + 1, 8) = strAtt3
                End If
                If Cells(lngRow, 6) <> "" Then
                    strAtt1 = Cells(lngRow, 6)
                End If
                If Cells(lngRow, 7) <> "" Then
                    strAtt2 = Cells(lngRow, 7)
                End If
                If Cells(lngRow, 8) <> "" Then
                    strAtt3 = Cells(lngRow, 8)
                End If
    
            End If
        Next
    Cells(lngRow + 1, 6) = strAtt1
    Cells(lngRow + 1, 7) = strAtt2
    Cells(lngRow + 1, 8) = strAtt3
    
    End Sub
    

      


    Betrifft: AW: Verdichtung einer Tabelle
    von: bluebeagle
    Geschrieben am: 23.07.2003 13:33:29

    Hi,

    hier ist noch eine Lösungsmöglichkeit, etwas abweichend und kürzer vom ursprünglichen Script, aber voll funktionierend.

    gruss
    Bluebeagle

    Sub CompressDB()
    
    Dim lngRow As Long
    Dim strLand, strFirma, strName, strID
    
        For lngRow = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
        
            If Cells(lngRow, 1) = strLand And _
                Cells(lngRow, 2) = strFirma And _
                Cells(lngRow, 3) = strName And _
                Cells(lngRow, 4) = strID Then
                
                If Cells(lngRow + 1, 6) <> "" Then
                    Cells(lngRow, 6) = Cells(lngRow + 1, 6)
                End If
                If Cells(lngRow + 1, 7) <> "" Then
                    Cells(lngRow, 7) = Cells(lngRow + 1, 7)
                End If
                If Cells(lngRow + 1, 8) <> "" Then
                    Cells(lngRow, 8) = Cells(lngRow + 1, 8)
                End If
                Rows(lngRow + 1).Delete
                
             Else
            
                strLand = Cells(lngRow, 1)
                strFirma = Cells(lngRow, 2)
                strName = Cells(lngRow, 3)
                strID = Cells(lngRow, 4)
                
            End If
            
        Next
    
    End Sub
    



      


    Betrifft: AW: Verdichtung einer Tabelle
    von: Nike
    Geschrieben am: 23.07.2003 12:20:10

    Hi,
    ich glaub ich hab vergessen die str wieder zurückzusetzen,
    also mal so versuchen:

    Bye

    Nike

    Sub reduceDB()
    Dim lngRow As Long
    
        For lngRow = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
            If Cells(lngRow, 1) = strLand And _
                Cells(lngRow, 2) = strFirma And _
                Cells(lngRow, 3) = strName And _
                Cells(lngRow, 4) = strID Then
                
                If Cells(lngRow, 6) <> "" Then
                    strAtt1 = Cells(lngRow, 6)
                End If
                If Cells(lngRow, 7) <> "" Then
                    strAtt2 = Cells(lngRow, 7)
                End If
                If Cells(lngRow, 8) <> "" Then
                    strAtt3 = Cells(lngRow, 8)
                End If
                Rows(lngRow + 1).Delete
            Else
    
                strLand = Cells(lngRow, 1)
                strFirma = Cells(lngRow, 2)
                strName = Cells(lngRow, 3)
                strID = Cells(lngRow, 4)
                If lngRow <> Cells(Rows.Count, 1).End(xlUp).Row Then
                    Cells(lngRow + 1, 6) = strAtt1
                    Cells(lngRow + 1, 7) = strAtt2
                    Cells(lngRow + 1, 8) = strAtt3
                End If
    
    strAtt1 =""
    strAtt2 =""
    strAtt3 =""
    
                If Cells(lngRow, 6) <> "" Then
                    strAtt1 = Cells(lngRow, 6)
                End If
                If Cells(lngRow, 7) <> "" Then
                    strAtt2 = Cells(lngRow, 7)
                End If
                If Cells(lngRow, 8) <> "" Then
                    strAtt3 = Cells(lngRow, 8)
                End If
    
            End If
        Next
    Cells(lngRow + 1, 6) = strAtt1
    Cells(lngRow + 1, 7) = strAtt2
    Cells(lngRow + 1, 8) = strAtt3
    
    End Sub
    



      


    Betrifft: AW: Verdichtung einer Tabelle
    von: bluebeagle
    Geschrieben am: 23.07.2003 13:34:56

    Hi Nike,

    habe noch eine Lösung erhalten ist etwas kürzer.

    gruss
    bluebeagle

    Sub CompressDB()
    
    Dim lngRow As Long
    Dim strLand, strFirma, strName, strID
    
        For lngRow = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
        
            If Cells(lngRow, 1) = strLand And _
                Cells(lngRow, 2) = strFirma And _
                Cells(lngRow, 3) = strName And _
                Cells(lngRow, 4) = strID Then
                
                If Cells(lngRow + 1, 6) <> "" Then
                    Cells(lngRow, 6) = Cells(lngRow + 1, 6)
                End If
                If Cells(lngRow + 1, 7) <> "" Then
                    Cells(lngRow, 7) = Cells(lngRow + 1, 7)
                End If
                If Cells(lngRow + 1, 8) <> "" Then
                    Cells(lngRow, 8) = Cells(lngRow + 1, 8)
                End If
                Rows(lngRow + 1).Delete
                
             Else
            
                strLand = Cells(lngRow, 1)
                strFirma = Cells(lngRow, 2)
                strName = Cells(lngRow, 3)
                strID = Cells(lngRow, 4)
                
            End If
            
        Next
    
    End Sub
    



      


    Betrifft: AW: Verdichtung einer Tabelle
    von: bluebeagle
    Geschrieben am: 23.07.2003 12:55:29

    Yipiieeehhh!
    Es funzt!
    Danke Nike.

    gruss
    Bluebeagle