Tabellen vergleichen, aber knifflich

Informationen und Beispiele zu den hier genannten Dialog-Elementen:

Tabellen vergleichen, aber knifflich von artuk vom 04.04.2005 10:23:00

AW: Tabellen vergleichen, aber knifflich - von Hajo_Zi am 04.04.2005 10:50:28
- AW: Tabellen vergleichen, aber knifflich - von artuk am 04.04.2005 10:53:59
AW: Tabellen vergleichen, aber knifflich - von Fritz am 04.04.2005 11:10:43
- vielen,vielen dank, alles top!!!! - von artuk am 04.04.2005 11:27:29

Betrifft: Tabellen vergleichen, aber knifflich von: artuk
Geschrieben am: 04.04.2005 10:23:00

Hallo alle zusammen,

habe folgendes Problem,ich habe zwei Tabellenblätter. Diese sollen nach Händlernummer verglichen werden und die dazugehörigen Daten aus der Spalte G Tabelle 2 in die Splate Q Tabelle 1 geschrieben werden.
siehe das beispiel

https://www.herber.de/bbs/user/20659.xls

und hier das Marko, wie kann ich das ergänzen, damit es funktioniert?


Sub Vergleichen()
Dim LoI As Long
    Dim LoJ As Long
    Dim LoLetzte1 As Long
    Dim LoLetzte2 As Long
    Dim Loletzte3 As Long
    With Worksheets("Tabelle1")
        LoLetzte1 = IIf(IsEmpty(.Range("A65536")), .Range("A65536").End(xlUp).Row, 65536)
    End With
    With Worksheets("Tabelle2")
        LoLetzte2 = IIf(IsEmpty(.Range("b65536")), .Range("b65536").End(xlUp).Row, 65536)
    End With
    For LoI = 1 To LoLetzte1
        For LoJ = 1 To LoLetzte2
            ' Leerzellen nicht kennzeichnen
            If Worksheets("Tabelle1").Cells(LoI, 1) <> "" Then
                If Worksheets("Tabelle1").Cells(LoI, 1) = Worksheets("Tabelle2").Cells(LoJ, 2) Then
                    Worksheets("Tabelle1").Rows(LoI).Copy
                    With Worksheets("Tabelle3")
                        Loletzte3 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
                        If Loletzte3 > 65536 Then
                            MsgBox "In Tabelle3 ist keine Zeile mehr frei"
                            Application.CutCopyMode = False
                            Exit Sub
                        End If
                        .Rows(Loletzte3).PasteSpecial Paste:=xlValues         
                        .Rows(Loletzte3).PasteSpecial Paste:=xlFormats     
                    End With
                    Exit For    
                End If
            End If
        Next LoJ
    Next LoI
    Application.CutCopyMode = False
End Sub

Vielen Dank für die Hilfe

MFG

Aruk

Betrifft: AW: Tabellen vergleichen, aber knifflich von: Hajo_Zi
Geschrieben am: 04.04.2005 10:50:28

Hallo Artuk,

eins ist mir immer unklar? Warum müssen immer als erstes der Ursprungshinweis und die Kommentare entfernt werden.

Bitte keine Mail, Probleme sollten im Forum gelöst werden.
Microsoft MVP für Excel
Das Forum lebt auch von den Rückmeldungen.
Betriebssystem XP Home SP2 und Excel Version 2003 SP1.

Betrifft: AW: Tabellen vergleichen, aber knifflich von: artuk
Geschrieben am: 04.04.2005 10:53:59

Hallo Hajo,

ich habe das so im Forum gefunden. Ist es von dir?Dann sorry, dass man das nicht sieht.
Ich habe das nicht aus böser Absicht gemacht.Sorry!!
Vielleicht kannst du mir bei diesem Problem helfen, wäre echt toll
Vielen Dank!!

MFG

artuk

Betrifft: AW: Tabellen vergleichen, aber knifflich von: Fritz
Geschrieben am: 04.04.2005 11:10:43

Hi Aruk,

Versuch mal folgenden Code für Dein Problem.


Sub Vergleichen()
Dim LoI As Long
    Dim LoJ As Long
    Dim LoLetzte1 As Long
    Dim LoLetzte2 As Long
    Dim Loletzte3 As Long
    Dim ws1, ws2 As Worksheet
    Set ws1 = Worksheets("Tabelle1")
    Set ws2 = Worksheets("Tabelle2")
    LoLetzte1 = ws1.Cells(65536, 3).End(xlUp).Row
    LoLetzte2 = ws2.Cells(65536, 1).End(xlUp).Row
    For LoI = 2 To LoLetzte1
        For LoJ = 2 To LoLetzte2
            If ws1.Cells(LoI, 3) <> "" Then
                If ws1.Cells(LoI, 3) = ws2.Cells(LoJ, 1) Then
                   ws1.Cells(LoI, 17) = ws2.Cells(LoJ, 7)
                   Exit For
                End If
            End If
        Next LoJ
    Next LoI
End Sub

Fritz

Betrifft: vielen,vielen dank, alles top!!!! von: artuk
Geschrieben am: 04.04.2005 11:27:29

hi Fritz,

super sache, funktioniert perfekt. Vielen,vielen dank

MFG

artuk