zumarani
May 21, 2024
view681
view6
0
Goto Top

Per VBA sortieren und markieren

GermanQuestionMicrosoft
Hallo zusammen,
ich habe eine Sorge, die ihr vielleicht verringern könntet.
Seit geraumer Zeit arbeite ich, kurz gesagt, an einer VBA, die zwei *.csv-Dateien in ein Tabellenblatt einlesen soll und anschließend miteinander vergleicht und Unterschiede markiert.
Mein Problem ist nun, dass ich sie zwar problemlos einlesen und auch die überflüssigen Spalten ausblenden kann, aber die Sortierungen und Markierungen nicht so funktionieren, wie ich es erhoffe.
Sagen wir in der ersten Tabelle steht, in separaten Spalten zum Beispiel „Max“, „Mustermann“, „Office 365“ und „Sara“, „Musterfrau“, „Adobe CS“. Das Ding ist nun, dass sich im nächsten Monat, also in der neuen *.csv, die Reihenfolge der Namen und Programme ändern und / oder wegfallen können.
Kann mir jemand helfen, die VBA so zu bearbeiten, dass sie begreift, das „Max“, „Mustermann“ und „Office 365“ zusammengehören, wenn sie in der ersten Tabelle zusammen stehen und es markiert, wenn im nächsten Monat „Office 365+Adobe CC“ steht?! Ebenso, dass Lücken bleiben, wenn ein Name wegfällt und die übrigen Zeilen nicht nachrücken und mir das auch markiert wird.
Ich hoffe, es ist verständlich, was mein Problem ist?! Leider bin ich nicht sonderlich versiert, was VBA angeht und habe mir das Meiste aus Foren und Gesprächen mit ChatGPT zusammengeschraubt.
Ein, zwei Ansätze habe ich hier auch schon im Forum entdeckt, es mag also seien, dass ihr Codezeilen wiederentdeckt. Falls die von euch sind, habt vielen Dank, dass ihr zu meiner Reise beigetragen habt. Ein Profi mag herzlich über diesen Versuch lachen, aber irgendwo muss man ja anfangen.
Bitte seht es mir nach, dass ich den Code, alles was ich zu dem Thema erstellt habe, also redundant erscheinen mag, erstmal nur so reinkopiert habe. Ich lerne immer noch dazu.

Sub Markiere_Unterschiede()
     Dim lastRow As Long
    
'Die letzte Zeile in Spalte M und AT finden  
     lastRow = 500
    
'Sortieren der Daten in Spalten M und AT  
     Tabelle1.Range("M8:M" & lastRow).Sort Key1:=Tabelle1.Range("M8"), Header:=xlYes, Order1:=xlAscending, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin  
    Tabelle1.Range("AT8:AT" & lastRow).Sort Key1:=Tabelle1.Range("AT8"), Header:=xlYes, Order1:=xlAscending, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin  
    
Dim i As Long
'Durchlaufen der Zellen in den Spalten M und AT und Markieren der Unterschiede  
    For i = 8 To lastRow
        If Tabelle1.Cells(i, "M").Value <> Tabelle1.Cells(i, "AT").Value Then  
            Tabelle1.Cells(i, "M").Interior.Color = RGB(238, 106, 167) 'HotPink2 markieren, um Unterschiede anzuzeigen  
            Tabelle1.Cells(i, "AT").Interior.Color = RGB(238, 106, 167) 'HotPink2 markieren, um Unterschiede anzuzeigen  
        End If
    Next i
End Sub
_______________________________________________________________________________________________________________________________________

Sub Vergleiche_Nachnamen()
    Dim lastRow As Long
    
'Die letzte Zeile in Spalte J und AQ finden  
    lastRow = 500
    
'Sortieren der Daten in Spalten J und AQ  
    Tabelle1.Range("J8:J" & lastRow).Sort Key1:=Tabelle1.Range("J8"), Header:=xlYes  
    Tabelle1.Range("AQ8:AQ" & lastRow).Sort Key1:=Tabelle1.Range("AQ8"), Header:=xlYes  
    
    Dim i As Long
    
'Durchlaufen der Zellen in den sortierten Spalten J und AQ und Markieren der Unterschiede  
    For i = 2 To lastRow
        If Tabelle1.Cells(i, "J").Value <> Tabelle1.Cells(i, "AQ").Value Then  
            'Wenn ein Name in AQ hinzugekommen ist, der nicht in J vorhanden ist, markieren wir in Grüngelb  
            If Tabelle1.Cells(i, "AQ").Value <> "" And Tabelle1.Cells(i, "J").Value = "" Then  
                Tabelle1.Cells(i, "J").Interior.Color = RGB(173, 255, 47) 'Grüngelb markieren, um neuen Namen anzuzeigen  
            End If
            
            'Wenn ein Name in J steht, der in AQ nicht mehr vorkommt, markieren wir in DarkSalmon  
            If Tabelle1.Cells(i, "J").Value <> "" And Tabelle1.Cells(i, "AQ").Value = "" Then  
                Tabelle1.Cells(i, "J").Interior.Color = RGB(233, 150, 122) 'DarkSalmon markieren, um fehlenden Namen anzuzeigen  
            End If
        End If
    Next i
End Sub

_______________________________________________________________________________________________________________________________________
Sub Sortiere_Daten()
    Dim lastRow As Long
    
'Die letzte Zeile in Spalte M der ersten CSV-Datei finden  
    lastRow = Tabelle1.Cells(500, "M").End(xlUp).Row  
    
'Sortieren der Daten in Spalte M (Lizenzen)  
    Tabelle1.Range("B7:M" & lastRow).Sort Key1:=Tabelle1.Range("M7"), Header:=xlNo, MatchCase:=False, Orientation:=xlSortColumns, SortMethod:=xlPinYin  
    
'Markieren der Unterschiede nach dem Sortieren  
    Markiere_Unterschiede
End Sub
_______________________________________________________________________________________________________________________________________
Sub ZusammenfassenUndVerschieben()
    Dim ws As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long, j As Long
    Dim searchString As String
    Dim combinedInfo As String
    Dim foundMatch As Boolean
        
'Arbeitsblätter festlegen  
    Set ws = ThisWorkbook.Sheets("Tabelle1")  
    
 'Letzte Zeilen in den Tabellen finden  
    lastRow1 = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row  
    lastRow2 = ws.Cells(ws.Rows.Count, "AI").End(xlUp).Row  
    
'Begrenzung der Spaltenbreite für die erste Tabelle  
    Dim rangeTable1 As Range
    Set rangeTable1 = ws.Range("B7:B500,H7:H500,J7:J500,M7:M500,AE7:AE500")  
    
'Begrenzung der Spaltenbreite für die zweite Tabelle  
    Dim rangeTable2 As Range
    Set rangeTable2 = ws.Range("AI7:AI500,AO7:AO500,AQ7:AQ500,AT7:AT500,BL7:BL500")  
    
'Durchlaufen der Zeilen in der ersten Tabelle  
    For i = 7 To lastRow1
        'Kombinieren der Informationen aus den verschiedenen Spalten zu einem String  
        combinedInfo = ws.Cells(i, "B").Value & ", " & _  
                       ws.Cells(i, "H").Value & ", " & _  
                       ws.Cells(i, "J").Value & ", " & _  
                       ws.Cells(i, "M").Value & ", " & _  
                       ws.Cells(i, "AE").Value  
                       
'Standardmäßig keine Übereinstimmung gefunden  
        foundMatch = False
                       
'Durchlaufen der Zeilen in der zweiten Tabelle  
        For j = 7 To lastRow2
            'Suchen nach einer Übereinstimmung in der zweiten Tabelle  
            searchString = ws.Cells(j, "AI").Value & ", " & _  
                           ws.Cells(j, "AO").Value & ", " & _  
                           ws.Cells(j, "AQ").Value & ", " & _  
                           ws.Cells(j, "AT").Value & ", " & _  
                           ws.Cells(j, "BL").Value  
                           
          If combinedInfo = searchString Then
                'Wenn Übereinstimmung gefunden wurde, kopiere den String in die erste Tabelle  
                ws.Cells(i, "B").Resize(, 5).Value = ws.Cells(j, "AI").Resize(, 5).Value  
                foundMatch = True
                Exit For 'Stoppe die Suche, wenn Übereinstimmung gefunden wurde  
            End If
        Next j
        
        'Wenn keine Übereinstimmung gefunden wurde, markiere die Zeile in der ersten Tabelle  
        If Not foundMatch Then
            ws.Rows(i).Interior.Color = RGB(233, 150, 122) 'Markieren, um fehlende Daten anzuzeigen  
        End If
    Next i
    
    'Autofit für die Spalten der ersten Tabelle anwenden  
    rangeTable1.EntireColumn.AutoFit
    
    'Autofit für die Spalten der zweiten Tabelle anwenden  
    rangeTable2.EntireColumn.AutoFit
End Sub

Sub SynchronisiereTabellenMitDictionary()
    Dim ws As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long, j As Long
    Dim dictTable2 As Object
    Dim key As String
    Dim data1 As String
    Dim data2 As String

    'Arbeitsblatt festlegen  
    Set ws = ThisWorkbook.Sheets("Tabelle1")  

    'Letzte Zeilen in den Tabellen finden  
    lastRow1 = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row  
    lastRow2 = ws.Cells(ws.Rows.Count, "AI").End(xlUp).Row  

    'Dictionary erstellen  
    Set dictTable2 = CreateObject("Scripting.Dictionary")  

    'Daten aus der zweiten Tabelle in das Dictionary laden  
    For j = 7 To lastRow2
        key = ws.Cells(j, "AI").Value & "|" & ws.Cells(j, "AO").Value & "|" & ws.Cells(j, "AQ").Value & "|" & ws.Cells(j, "AT").Value & "|" & ws.Cells(j, "BL").Value  
        dictTable2(key) = j ' Speichere die Zeilennummer als Wert  
    Next j

    'Durchlaufe alle Zeilen in der ersten Tabelle  
    For i = 7 To lastRow1
        key = ws.Cells(i, "B").Value & "|" & ws.Cells(i, "H").Value & "|" & ws.Cells(i, "J").Value & "|" & ws.Cells(i, "M").Value & "|" & ws.Cells(i, "AE").Value  

        'Überprüfen, ob der Schlüssel in der zweiten Tabelle vorhanden ist  
        If dictTable2.exists(key) Then
            'Wenn der Schlüssel vorhanden ist, kopiere die Werte  
            data2 = ws.Cells(dictTable2(key), "AI").Value & ", " & _  
                    ws.Cells(dictTable2(key), "AO").Value & ", " & _  
                    ws.Cells(dictTable2(key), "AQ").Value & ", " & _  
                    ws.Cells(dictTable2(key), "AT").Value & ", " & _  
                    ws.Cells(dictTable2(key), "BL").Value  

            ws.Cells(i, "B").Resize(, 5).Value = ws.Cells(dictTable2(key), "AI").Resize(, 5).Value  
        Else
            ' Wenn der Schlüssel nicht vorhanden ist, markiere die Zeile in der ersten Tabelle  
            ws.Rows(i).Interior.Color = RGB(255, 0, 0) ' Rot markieren, um fehlende Daten anzuzeigen  
        End If
    Next i

    'Optional: Markiere Zeilen in der zweiten Tabelle, die nicht in der ersten Tabelle vorhanden sind  
    For j = 7 To lastRow2
        key = ws.Cells(j, "AI").Value & "|" & ws.Cells(j, "AO").Value & "|" & ws.Cells(j, "AQ").Value & "|" & ws.Cells(j, "AT").Value & "|" & ws.Cells(j, "BL").Value  
        If Not dictTable2.exists(key) Then
            ws.Rows(j).Interior.Color = RGB(0, 255, 0) ' Grün markieren, um neue Daten anzuzeigen  
        End If
    Next j
End Sub
comment-contentCommentShareShare
Share on Facebook Share on Twitter Share on Reddit Share on Linkedin

Content-Key: 61804882160

Url: https://administrator.de/contentid/61804882160

Printed on: July 27, 2024 at 14:07 o'clock

6 Comments
Latest comment
Goto Top
Member: kpunkt
kpunkt May 21, 2024 updated at 11:16:32 (UTC)
Goto Top
Teste separat einfach mal
Tabelle1.Range("B7:M" & lastRow).Sort Key1:=Tabelle1.Range("M7"), Header:=xlNo
Ich gehe davon aus, dass du da keine chinesischen Schriftzeichen verwendest.

Hier zum nachklöppeln
https://www.excel-vba-lernen.de/16-sortierfunktion
Member: Zumarani
Zumarani May 24, 2024 at 11:15:45 (UTC)
Goto Top
Hallo kpunkt,
danke schon mal für deine Antwort und den Link.

Die Tabelle ist zwar ohne chinesische Schriftzeichen, aber dafür mit Gekritzel bei Umlauten, wie zum Beispiel Süleyman.

Dein Code-Schnippsel funktionier zwar, hat mir aber leider, genau wie die Sortier-Funktion aus dem Link, nicht weitergeholfen.
Das Sachen werden dennoch vermischt sortiert. Gefühlt sogar noch schlimmer als vorher, als ob er nicht wüsste, wonach er sortieren soll.
Member: kpunkt
kpunkt May 27, 2024 at 05:19:34 (UTC)
Goto Top
Lass mal diese & lastRow weg
Sortiert bei mir einwandfrei.
Member: Zumarani
Zumarani May 31, 2024 at 08:10:45 (UTC)
Goto Top
Das führt bei mir immer zum Laufzeitfehler 1004.
Member: kpunkt
kpunkt Jun 03, 2024 at 05:53:24 (UTC)
Goto Top
Da tippe ich auf eine falsche Bennennung derTabellen im Code oder aber auf geschützte Bereiche.
Einfach mal mit einer neuen, kleinen Tabelle in einem separaten Sheet testen.
Member: Zumarani
Zumarani Jun 14, 2024 at 11:05:20 (UTC)
Goto Top
Verzeih die späte Antwort, ich lag flach.
Nein, sowas kann ich leider komplett ausschließen. Vollzugriff, nur ein einziger Name ("Tabelle1"), da hat sich leider kein Fehler eingeschlichen.
Aber ich teste das nochmal, wie Du gesagt bzw. geschrieben hast.
GermanQuestionMicrosoft