VBA: Werte vergleichen, Zellen kopieren

[Dominik Henne]

Hallo NG,

ich habe gesehen, dass es schon einige Threads zum Thema "Tabellen
vergleichen" gibt, jedoch ist nicht das Richtige für mich dabei.
Ich habe ein Tabellenblatt ("Tabelle1") mit Werten, wobei der Wert in
Spalte "B" auch irgendwo in Spalte "B" des Blatts "Testdaten1"
vorkommt. Mein Ziel ist es den zugehörigen Wert im Sheet "Testdaten1"
zu finden und die Zellen A:G in "Tabelle1" I:O einzutragen.
Bei meinem Code tritt immer der Fehler 1004 ("Anwendungs- oder
objektdefinierter Fehler") auf:

'*******************************************
Dim Search As String, rng As Range
Dim Sp As String, FirstAddress As String
Dim c As Integer

Sp = "B"
c = 1

Do Until c = Worksheets("Tabelle1").UsedRange.Rows.Count
c = c + 1
Search = Worksheets("Tabelle1").Range("B" & c).Value
Set rng = Worksheets("Testdaten1").Range("B:B").Find _
(What:=Search, LookAt:=xlPart, LookIn:=xlValues)
If Not rng Is Nothing Then
FirstAddress = rng.Address
Do
With Worksheets("Tabelle1")
Worksheets("Testdaten1").Range("A" & rng & ":G" & rng).Copy _ 'hier
kommt die
Destination:=Worksheets("Tabelle1").Range("I" & c)
'Fehlermeldung
End With
Set rng = Worksheets("Testdaten1").Range("B:B").FindNext(after:=rng)
If rng.Address = FirstAddress Then Exit Do
Loop
End If
Loop
'*******************************************

Ich hoffe, dass mir jemand helfen kann.

Danke im Voraus.

Gruß,
Dominik
-
Win XP Pro, Excel 2003

[Kai Ottenbacher]

Hallo Dominik,

ungetestet:

Ändere mal die Zeile
Worksheets("Testdaten1").Range("A" & rng & ":G" & rng).Copy

zu
Worksheets("Testdaten1").Range("A" & rng.Row & ":G" & rng.Column).Copy
damit VBA auch weiß, welche Zeile und Spalte kopiert werden soll...

Gruss, Kai

[Dominik Henne]

Hallo Kai,

kleiner Fehler, große Wirkung. Danke für deine Hilfe.

Prinzipiell läuft das Programm jetzt. Da ich aber ca. 30.000 Zeilen in
jedem Arbeitsblatt habe, dauert ein Durchlauf extrem lange. Wie lange
kann ich nicht sagen, da ich nach einer Stunde (CPU-Auslastung 100%)
Excel beendet habe.

Gibt es noch irgendeine Möglichkeit den Vorgang zu beschleunigen?

Danke für Eure Hilfe.

Gruß,
Dominik

[Kai Ottenbacher]

Hallo Dominik,

wäre es evtl. eine Idee, die zu Kopierenden Zeilen in "Testdaten1" per
Filter zu ermitteln um dann die sichtbaren Zeilen nach "Tabelle1" zu
kopieren? Damit sollte der Vorgang wesentlich schneller ablaufen als
jedes Mal 30000 Zellen zu durchsuchen.

Gruss, Kai

[Dominik Henne]

Hallo Kai,

eigentlich eine gute Idee, geht aber nicht, weil nicht alle Werte in
beiden Tabellen vorhanden sind.

Ich lasse es heute mal über Nacht laufen, und gucke was raus kommt.
Ich melde mich dann morgen wieder.

Danke für deine Hilfe.

Gruß,
Dominik

[Dominik Henne]

Hallo Kai,

nach 2 Stunden war das Programm durchgelaufen.

Eigentlich sollten ja bei identischen Werten in Spalte "B" die Zellen A
bis G aus Testdaten1 in Tabelle1 kopiert werden. Leider hat die
Zuordnung überhaupt nicht funktioniert. Es wurden zwar alle Werte aus
Testdaten1 in Tabelle1 kopiert, aber leider passen die Werte nicht
zusammen.

Das Problem muss also am Anfang des Codes sein. Ich denke mal, dass
"Search = Worksheets("Tabelle1").Range("B" & c).Value " nicht den Wert
ausgibt der in der Zelle steht. Ich weiß aber auch nicht wie ich die
Werte sonst vergleichen und suchen soll.

Ich hoffe jemand kann mir eine Hilfestellung geben.

Schon mal Danke im Voraus.

Gruß,
Dominik

[Kai Ottenbacher]

Hallo Domik,

2 Fragen:
- können in deinen Quelldaten (Testdaten1) in den durchsuchten Werten
Duplikate vorkommen? wenn ja, wie soll mit diesen verfahren werden?
- können in deiner Zieltabelle (Tabelle1) in den Suchkriterien
Duplikate vorkommen? wenn ja, wie soll mit diesen verfahren werden?
Gruss, kai

[Dominik Henne]

Hallo Kai,

in beiden Tabellen kommen alle Werte in Spalte B nur jeweils ein Mal
vor.

Ich versuche das Ganze jetzt mal mit einer For...Each Schleife.

Gruß,
Dominik

[Kai Ottenbacher]

Hallo Domik,

ich habe mal versucht, dein Problem nachzustellen unter folg.
Prämissen, die du evtl. noch im Code abändern musst:
Quelldaten: Sheets("Quelle")
Zieldaten: Sheets("Ziel")
Die zu vergleichenden Werte stehen jeweils in Spalte "A"
Bei Übereinstimmung werden die Spalten "A" und "B" aus dem Blatt
"Quelle" in Spalte "B" und "C" um Blatt "Ziel" kopiert.
Funktioniert soweit die Werte jeweils nur 1x vorkommen und geht mE.
recht schnell.
Das 'Sheet("Quelle").Activate' ist zwar hässlich, aber ohne gibt's
eine Fehlermeldung, die ich anders nicht in den Griff bekomme.

Sub Kopieren()
Dim rngZiel As Range, rngQuelle As Range
For Each rngZiel In Sheets("Ziel").Range("A1:A" &
(Sheets("Ziel").Cells(Rows.Count, 1).End(xlUp).Row))
With Sheets("Quelle").Range("A1:A" &
(Sheets("Quelle").Cells(Rows.Count, 1).End(xlUp).Row))
Set rngQuelle = .Find(rngZiel.Value, LookIn:=xlValues,
LookAt:=xlWhole)
If Not rngQuelle Is Nothing Then
With Sheets("Quelle")
.Activate
.Range(Cells(rngQuelle.Row, rngQuelle.Column),
Cells(rngQuelle.Row, rngQuelle.Column + 1)).Copy _
Destination:=Sheets("Ziel").Cells(rngZiel.Row,
rngZiel.Column + 1)
End With
End If
End With
Next rngZiel
End Sub

Gruss, kai

[Dominik Henne]

Hi Kai,

ich habe es mittlerweile auch mit der For...Each Schleife probiert.

Dauert mir aber immer noch zu lange.

Vielen Dank für deine Unterstützung.

Gruß,
Dominik

[Lars P. Wolschner]

Post by Kai Ottenbacher
Hallo Domik,
ich habe mal versucht, dein Problem nachzustellen unter folg.
Quelldaten: Sheets("Quelle")
Zieldaten: Sheets("Ziel")

Da würde ich die Namen der Tabellenblätter als Parameter nehmen und
in der Sub erstmal Worksheet-Objekte dazu anlegen:

Public Sub Copy( _
ByVal xls As Excel.Workbook, _
ByRef strWorksheetFrom As String, _
ByRef strWorksheetTo As String)

On Error Resume Next
Dim shtFrom As Excel.Worksheet, shtTo As Excel.Worksheet
Set shtFrom = xls.Worksheets(strWorksheetFrom)
Set shtTo = xls.Worksheets(strWorksheetTo)
If (shtFrom Is Nothing) Or (shtTo Is Nothing) Then Exit Sub

'...

End Sub

CU

[Michael Schwimmer]

Hallo Dominik,

Post by Dominik Henne
Prinzipiell läuft das Programm jetzt. Da ich aber ca. 30.000 Zeilen
in jedem Arbeitsblatt habe, dauert ein Durchlauf extrem lange. Wie
lange kann ich nicht sagen, da ich nach einer Stunde (CPU-Auslastung
100%) Excel beendet habe.

unakzeptabel!

Post by Dominik Henne
Gibt es noch irgendeine Möglichkeit den Vorgang zu beschleunigen?

Probiere mal folgenden Code. Bei 65536 gefüllten Zeilen (umgekehrte
Sortierung) hat der Vorgang bei mir auf dem Laptop Athlon 4 1200 MHz
ca. 20 Sekunden gedauert.

Sub Übertragen()
Dim colDummy As Collection
Dim colZeilen As New Collection
Dim i As Long
Dim k As Long
Dim strSearch As String
Dim varDummy As Variant
Dim wsZiel As Worksheet
Dim wsQuelle As Worksheet
Dim dtmBeginn As Date

On Error Resume Next

dtmBeginn = Now

Set wsZiel = Worksheets("Tabelle1")
Set wsQuelle = Worksheets("Tabelle2")

With wsZiel 'Zieldatenblatt
For i = 1 To 65536
strSearch = CStr(.Cells(i, 2))
If strSearch <> "" Then
Set colDummy = New Collection
colZeilen.Add colDummy, "X-" & strSearch
colZeilen("X-" & strSearch).Add i, "Zielzeile"
End If
Next
End With

With wsQuelle 'Tabelle mit allen Daten
For i = 1 To 65536
strSearch = CStr(.Cells(i, 2))
If strSearch <> "" Then
colZeilen("X-" & strSearch).Add i, "Quellzeile"
End If
Next
End With

With wsZiel 'Zieldatenblatt
Application.ScreenUpdating = False
For Each varDummy In colZeilen
i = varDummy("Zielzeile")
k = varDummy("Quellzeile")
.Range(.Cells(i, 1), .Cells(i, 7)).Value = _
wsQuelle.Range( _
wsQuelle.Cells(k, 1), wsQuelle.Cells(k, 7) _
).Value
Next
Application.ScreenUpdating = True
End With

MsgBox "Dauer : " & Format(Now - dtmBeginn, "nn:ss")
End Sub


MfG
Michael

[Dominik Henne]

Hallo Michael,

ich kann nur sagen "Wow". Bei meinen Testdaten hat der Durchlauf 9
Sekunden gedauert.

Ich habe nur noch die Zielzellen für die kopierten Daten in "
.Range(.Cells(i, 9), .Cells(i, 15)).Value = wsQuelle.Range( ...."
geändert damit die Daten nebeneinander stehen und nicht überschrieben
werden.

Eine super Lösung. 1000 Dank an dich Michael.

Gruß,
Dominik

[Michael Schwimmer]

Hallo Dominik,

Post by Dominik Henne
ich kann nur sagen "Wow". Bei meinen Testdaten hat der Durchlauf 9
Sekunden gedauert.
Ich habe nur noch die Zielzellen für die kopierten Daten in "
.Range(.Cells(i, 9), .Cells(i, 15)).Value = wsQuelle.Range( ...."
geändert damit die Daten nebeneinander stehen und nicht überschrieben
werden.
Eine super Lösung. 1000 Dank an dich Michael.

freut mich, wenn's dir weiterhilft.
Und Danke für die Rückmeldung!

MfG
Michael

[Matthias Belleflamme]

Hallo zusammen,

habe heute erst den Thread entdeckt, weil ich ein ähnliches Problem wie
Dominik Henne habe.

Nur kopiert er bei dem von Euch entwickelten Code nicht alle Daten von der
Master- in die zu vergleichende Tabelle, obwohl diese dort auch vorhanden
und identisch sind.
Es handelt sich um Fahrtenlisten mit schwankend 2.500 bis 15.000 Zeilen.

Fahrtart lfd.Nummer Fahrt AB Fahrt AN Dauer d. Fahrt Ort AB
Ort AN FahrtOrg
Linienf 1 03:00 04:00 1:00
MUC CGN N
Linienf 2 03:04 03:46 0:42
ARG HGZ N
usw.

Habt Ihr noch eine Hilfestellung für mich