Макрос для проверки и добавления значений не работает

Question

Я получил довольно длинный макрос, в основном пытаясь сделать следующее:

1. открыть файл импорта
2. проверка идентичных значений файла импорта в целевом файле в нескольких столбцах
   • если найдено совпадение, обновите одну ячейку в целевом файле
   • , если не сопоставлено, добавьте еще одну строку

Это мой код до сих пор (яеще не очистил):

Public Declare PtrSafe Function SetCurrentDirectoryA Lib "kernel32" (ByVal lpPathName As String) As Long

Sub Import_Macro()

Dim wbData As Workbook
Dim wsData As Worksheet
Dim rngData As Range

Set rngData = Selection
Set wbData = Workbooks(rngData.Parent.Parent.Name)
Set wsData = wbData.Sheets("Fehleranalyse Daten")

'DATA IMPORT
Dim wbImport As Workbook
Dim wsImport As Worksheet
Dim Lastrow_wsData As String
Dim Lastrow_wsData_neu As String

Lastrow_wsData = wsData.Range("A:A").Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

'Import from file
MyPath = Application.ActiveWorkbook.Path
SetCurrentDirectoryA MyPath

strFileToOpen = Application.GetOpenFilename _
(Title:="Bitte Datei für Fehler-Reporting auswählen", _
FileFilter:="Excel Files *.xls*; *.csv (*.xls*; *.csv),")

'Defining names for Import
Dim rngImport As Range
Set rngImport = Selection
Set wbImport = Workbooks(rngImport.Parent.Parent.Name)
Set wsImport = wbImport.Sheets("Sheet1")
Dim Lastrow_Import As Long

Lastrow_Import = wsImport.Range("A:A").Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Dim AnmelderImport As Long
Dim AnmelderData As Long
Dim AbteilungImport As Long
Dim AbteilungData As Long
Dim VNrImport As Long
Dim VNrData As Long

Dim AuftragsNrImport As Long
Dim AuftragsNrData As Long
Dim VersuchImport As Long
Dim VersuchData As Long

Dim iCol As Long
Dim colnameData As Variant
Dim colnumImport As Variant

Dim lrData As Long
Dim lcData As Long
Dim lcImport As Long

Dim lrs As Long
Dim r As Long
Dim c As Long
Dim iSOP As Long
Dim j As Long

Dim i As Range
Dim k As Range
Dim n As Long

Dim Check As Variant
Dim arr As Variant

'Creating several array I need to either check for matching or copying
VersuchImport = Application.WorksheetFunction.Match("VERSUCH", wsImport.Range("11:11"), 0) 'Ermittlung der Spalte für Versuch
VersuchData = Application.WorksheetFunction.Match("VERSUCH", wsData.Range("1:1"), 0)
AuftragsNrImport = Application.WorksheetFunction.Match("AUFTRAGSNUMMER", wsImport.Range("11:11"), 0) 'Ermittlung der Spalte für Auftragsnr.
AuftragsNrData = Application.WorksheetFunction.Match("AUFTRAGSNUMMER", wsData.Range("1:1"), 0)
TestzweckImport = Application.WorksheetFunction.Match("TESTZWECK", wsImport.Range("11:11"), 0) 'Ermittlung der Spalte für Testzweck
TestzweckData = Application.WorksheetFunction.Match("TESTZWECK", wsData.Range("1:1"), 0)
StatusImport = Application.WorksheetFunction.Match("AUFTRAGSSTATUS", wsImport.Range("11:11"), 0) 'Ermittlung der Spalte für Status
StatusData = Application.WorksheetFunction.Match("AUFTRAGSSTATUS", wsData.Range("1:1"), 0)

Debug.Print "VersuchImport = " & VersuchImport
Debug.Print "VersuchData = " & VersuchData
Debug.Print "AuftragsNrImport = " & AuftragsNrImport
Debug.Print "AuftragsNrData = " & AuftragsNrData
Debug.Print "TestzweckImport = " & TestzweckImport
Debug.Print "TestzweckData = " & TestzweckData

With wsImport
    Check = .Range(.Cells(1, VersuchImport).Address, .Cells(Lastrow_Import, VersuchImport).End(xlUp).Address).Value2 & .Range(.Cells(1, AuftragsNrImport).Address, .Cells(Lastrow_Import, Auftragsnr).End(xlUp).Address).Value2
End With

'I'm creating another array with column names to be copied (bayed on target file)
With wsData
    lrData = wsData.Range("A:A").Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lcData = Application.WorksheetFunction.Match("AUFTRAGSSTATUS", .Range("1:1"), 0)
    colnameData = Application.Transpose(.Range(.Cells(1, 1), .Cells(1, lcData)).Value)
End With

'The corresponding array in the source file
With wsImport
    lcImport = Application.WorksheetFunction.Match("SORTIERUNG", .Range("11:11"), 0)
    ReDim colnumImport(lcImport, 1)
    For iCol = 1 To lcImport
    On Error Resume Next
        colnumImport(iCol, 1) = .Rows(11).Find(What:=colnameData(iCol, 1), LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
    Next iCol
End With

'This section copies all relevant columns and rows if not matched (not cleaned up though)
Dim lcellData As Range
Dim cellAuftragsNrImport As Range
Dim RngAuftragsNrImport As Variant
Dim RngAuftragsNrData As Variant
Dim Status As Long
Dim cellVersuchImport As Range
Dim RngVersuchImport As Variant
Dim RngVersuchData As Variant
Dim cellStatusImport As Range
Dim RngStatusImport As Variant
Dim RngStatusData As Variant
Dim cellTestzweckImport As Range
Dim RngTestzweckImport As Variant
Dim RngTestzweckData As Variant
Dim iZweck As Long

With wsImport
 RngAuftragsNrImport = .Range(.Cells(12, AuftragsNrImport).Address, .Cells(Lastrow_Import, AuftragsNrImport).Address).Value2
 RngTestzweckImport = .Range(.Cells(12, TestzweckImport).Address, .Cells(Lastrow_Import, TestzweckImport).Address).Value2
 RngVersuchImport = .Range(.Cells(12, VersuchImport).Address, .Cells(Lastrow_Import, VersuchImport).Address).Value2
 RngStatusImport = .Range(.Cells(12, StatusImport).Address, .Cells(Lastrow_Import, StatusImport).Address).Value2
End With

With wsData
 RngAuftragsNrData = .Range(.Cells(3, AuftragsNrData).Address, .Cells(Lastrow_wsData, AuftragsNrData).Address).Value2
 RngVersuchData = .Range(.Cells(3, VersuchData).Address, .Cells(Lastrow_wsData, VersuchData).Address).Value2
 RngStatusNrData = .Range(.Cells(3, StatusData).Address, .Cells(Lastrow_wsData, StatusData).Address).Value2
 RngTestzweckNrData = .Range(.Cells(3, TestzweckData).Address, .Cells(Lastrow_wsData, TestzweckData).Address).Value2
End With

ReDim arr(0)

For iZweck = LBound(RngTestzweckImport, 1) To UBound(RngTestzweckImport, 1)
    If RngTestzweckImport(iZweck, 1) = "Entwicklungstest" Then
       ReDim Preserve arr(j)
        arr(j) = iZweck + 11
        j = j + 1
    End If
Next iZweck

        For Each cellAuftragsNrImport In RngAuftragsNrImport
            With wsData.Cells 'RngAuftragsNrData.Cells
                Set i = .Find(cellAuftragsNrImport, LookIn:=xlValues, lookat:=xlWhole)
                    If Not i Is Nothing Then
                        k = i.Row
                        Status = .Cells(k, StatusData).Value
                        If cellStatusImport.Value <> Status Then
cellStatusImport.Copy Destination:=wsData.Cells(i.Row, StatusData)
                            End If
                        Else
                        With wsData
                            lrData = Lastrow_wsData
                            For r = LBound(arr) To UBound(arr)
                                lrData = .Cells(.Rows.Count, 1).End(xlUp).Row
                                    For c = 1 To lcData
                                        .Cells(lrData + 1, c).Value = wsImport.Cells(arr(r), colnumImport(c, 1)).Value
                                    Next c
                            Next r
                        End With
                        End If
                End With
            Next

End Sub

Все имена, заканчивающиеся на «Импорт», взяты из исходного файла.Все имена, заканчивающиеся на «Данные», относятся к целевому файлу.

Чего я пытаюсь достичь:
Макрос должен проверить, являются ли элементы исходного файла уже частью целевого файла.Это относится только к строкам, которые содержат значение «Entwicklungstest» (см. Arr).
Проверяемые критерии: AuftragsNr (идентификатор заказа), Testzweck и Date.Пока мой макрос проверяет только AuftragsNr.Даже для этого единственного критерия мой макрос не работает.Таким образом, в принципе, если в целевом файле не соблюдаются три вышеуказанных критерия, следует добавить новую строку.Если критерии выполнены, столбец «Состояние» должен быть обновлен значением из исходного файла.

При выполнении макроса все, что он делает, это добавляет все строки с «Entwicklungstest» после последней строкицелевой файл.
Кто-нибудь есть идеи, как решить эту проблему?Что мне нужно изменить!
Заранее большое спасибо за ваши усилия !!!