Zellen vergleichen aus 2 Dokumenten und einfügen von Werten

Question

Hallo zusammen,

ich sitze nun schon Stunden an meinem Problem, ich hoffe ihr könnt mir helfen.

Ich importiere aus einer Quelldatei mehrere Datensätze, indem ich die Datei über ein Makro öffne. In diesem Teil habe ich das Problem das die letzet Zeiel nicht korrekt ermittelt wird. Woran kann das liegen?

Makro bisher:

Function Datenimport()

Dim varName As Variant
Dim i As Integer
Dim letzte_Zeile As Variant

varName = Application.GetOpenFilename("Excel Dateien,*.xls")
If varName = False Then Exit Function
Application.EnableEvents = False
Workbooks.Open varName
With ActiveWorkbook

'letzte_Zeile = Worksheets("Rohdaten").Cells(Rows.Count, 1).End(xlUp).Row
letzte_Zeile = 10083

Worksheets("Rohdaten").Range("A4:A" & letzte_Zeile).Copy _
Destination:=ThisWorkbook.Worksheets("Messwerte").Range("A4").Offset(0, 0)

Worksheets("B_Temperaturen Trockner").Range("C4:C10083").Copy
With ThisWorkbook.Worksheets("Messwerte").Range("C4")
.PasteSpecial Paste:=xlValues ' Werte
.PasteSpecial Paste:=xlFormats ' Formate
End With

Worksheets("B_Temperaturen Trockner").Range("D4:D10083").Copy
With ThisWorkbook.Worksheets("Messwerte").Range("G4")
.PasteSpecial Paste:=xlValues ' Werte
.PasteSpecial Paste:=xlFormats ' Formate
End With

Worksheets("B_k-Wert").Range("H4:H10083").Copy
With ThisWorkbook.Worksheets("Messwerte").Range("B4")
.PasteSpecial Paste:=xlValues ' Werte
.PasteSpecial Paste:=xlFormats ' Formate
End With

Worksheets("B_k-Wert").Range("J4:J10083").Copy
With ThisWorkbook.Worksheets("Messwerte").Range("E4")
.PasteSpecial Paste:=xlValues ' Werte
.PasteSpecial Paste:=xlFormats ' Formate
End With

Worksheets("B_k-Wert").Range("L4:L10083").Copy
With ThisWorkbook.Worksheets("Messwerte").Range("G4")
.PasteSpecial Paste:=xlValues ' Werte
.PasteSpecial Paste:=xlFormats ' Formate
End With

Worksheets("B_k-Wert").Range("M4:M10083").Copy
With ThisWorkbook.Worksheets("Messwerte").Range("H4")
.PasteSpecial Paste:=xlValues ' Werte
.PasteSpecial Paste:=xlFormats ' Formate
End With

Worksheets("B_Kohlemenge").Range("D4:D10083").Copy
With ThisWorkbook.Worksheets("Messwerte").Range("F4")
.PasteSpecial Paste:=xlValues ' Werte
.PasteSpecial Paste:=xlFormats ' Formate
End With
Application.CutCopyMode = False
.Close False
End With

Application.EnableEvents = True
End Function


Desweiteren möchte ich nun Daten miteinander vergleichen. Also ich besitze Datumangaben in Minuten schritten Bsp.

30.08.2010 00:55:00
30.08.2010 00:56:00
30.08.2010 00:57:00
30.08.2010 00:58:00

welche sich im aktuellen Dokument in Spalte A befinden. Nun möchte ich diese Datumsangaben aus Spalte A mit Daten aus der Quelldatei vergleichen. Wenn beide gleich sind soll ein Wert kopiert werden.

bisheriges Makro, welches leider nicht funktioniert:

Function Zuordnen()

Dim varName As Variant
Dim i, j As Integer
Dim letzte_Zeile As Variant

varName = Application.GetOpenFilename("Excel Dateien,*.xls")
If varName = False Then Exit Function
Application.EnableEvents = False
Workbooks.Open varName


Endi = 10083

Endj = 10083
For i = 1 To Endi
For j = i To Endj

If ActiveWorkbook.Worksheets("Restwassergehalt").Range("E" & i).Value = ThisWorkbook.Worksheets("Messwerte").Range("A" & j).Value Then
Worksheets("Restwassergehalt").Range("I" & j).Copy
ThisWorkbook.Worksheets("Messwerte").Range("J" & j).Paste

End If
Next j
Next i

ActiveWorkbook.Close False

End Function


Ich hoffe ich konnte mein Problem gut darstellen udn bekomme ein wenig Hilfestellung. Ich komm einfach nicht weiter. Danke schon mal.

Gruss Stefan

Answer 1

Hallo,

With Worksheets("Rohdaten")
letzte_Zeile = = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
End With

Gruß Hajo

Answer 2

Besten Dank Hajo, dass hat prima geklappt.

Nun bräuchte ich nur noch Hilfestellung bei meinem zweiten Problem.
Das Vergleichen von Datumsangaben und anschließendes Einfügen der passenden Werte. Mit dem angegeben Quelltext komm ich nicht weiter.

mfg Stefan

Answer 3

Ich hab mich nochmal rangesetzt udn folgendes Makro abgeändert

Sub Vergleichen()
Dim Search1 As Range
Dim Search2 As Range
Dim lastRowA As Long
Dim lastRowB As Long
lastRowA = Sheets("Messwerte").Range("A65536").End(xlUp).Row
lastRowB = Sheets("Temp").Range("A65536").End(xlUp).Row
For Each Search1 In Sheets("Messwerte").Range("A4:A" & lastRowA)
For Each Search2 In Sheets("Temp").Range("E8:E" & lastRowB)
If Search1.Text = Search2.Text Then
Search1.Interior.ColorIndex = 3

Sheets("Temp").Cells(Search2.Row, 9).Copy
Sheets("Messwerte").Cells(Search1.Row, 10).PasteSpecial
End If
Next
Next
End Sub

Es löst mein Problem jetzt über Umwege aber es macht es. Problem ist, dass es knapp 3 Minuten benötigt. Gibt es eine Möglichkeit um den Prozess zu beschleunigen.
Oder besser wäre es wenn man den Startpunkt festlegen könnte. So zu sagen, ab welchem Datum er anfangen soll zu suchen.
Ich über 10 000 Werte vergleichen lassen muss dauert dies eben Zeit.

Vielleicht hat ja jemand eine Idee.