Tabellen vergleichen, identische Werte kopieren
05.08.2019 15:49:44
Emma
ich habe glaube ich gerade ein Bett vorm Kopf, denn ich finde einfach nicht den Fehler in meiner Prozedur.
Die Prozedur soll aus einer Tabelle bestimmte Werte löschen (weil es sonst doppelte Werte gibt). Diesen Schritt erfüllt die Prozedur auch zuverlässig. Der nächste Schritt ist das Problem.
Hier soll die Prozedur zwei Tabellen vergleichen, die vorherige (Quell-Tabelle) mit einer Ziel-Tabelle. Bei identischen Bezeichnungen soll ein Wert aus der Quell-Tabelle in die Ziel-Tabelle eingefügt werden.
Beim ersten Mal hat auch alles geklappt, aber dann hat sich irgendwie mein PC auf gehangen.
Als ich es danach noch mal versuchen wollte, kam eine Fehlermeldung "Index außerhalb des gültigen Bereichs" an der Stelle, die in der unten stehenden Prozedur fett gedruckt ist.
Ich hoffe, jemand findet den Fehler.
Verglichen werden die Tabellen anhand von Bezeichnungen (z.B. Auto). Diese Bezeichnung steht in beiden Tabellen in anderen Spalten. In der Quell-Tabelle (Workbook: Test_1; Worksheet: X) steht die Bezeichnung in der ersten Spalte und der zu kopierende Wert in der 4. Spalte. In der Ziel-Tabelle (Worksheet:MesswertTest; Worksheet:Messw_2019) steht die Bezeichnung in Spalte 6 und der zu ergänzende Wert soll in der 10. Spalte stehen.
VariableTest soll die Bezeichnungen der Quell-Tabelle definieren und VariableMessw soll die Bezeichnungen der Ziel-Tabelle definieren.
Option Explicit
Sub Werte_übertragen()
Dim Test_1 As Workbook
Dim MesswertTest As Workbook
Dim X As Worksheet
Dim Messw_2019 As Worksheet
Dim Zeile1 As Long
Dim benutzt As Variant
Dim VariableTest As Variant
Dim VariableMessw As Variant
Dim suchwert As Variant
Dim gefunden As Range
Set Test_1 = Workbooks.Open("C:\Users\t0226770\Desktop\Test_1.xlsx")
benutzt = ActiveSheet.UsedRange.Select
For Zeile1 = 1 To ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
If ActiveSheet.Cells(Zeile1, 3) = "UESD" Then
Rows(Zeile1).Delete
End If
Next
Set VariableTest = ActiveSheet.Range("A:A")
Set VariableMessw = Workbooks("MesswertTest").Worksheets("Messw_2019").Range("F:F")
For Each suchwert In VariableMessw
Set gefunden = VariableTest.Find(suchwert, , , xlWhole)
If Not gefunden Is Nothing Then
gefunden.Offset(0, 3).Copy suchwert.Offset(0, 4)
End If
Next
End Sub