AW: Vergleiche Wert aus 2D-Array-A mit Wert aus 2D-Array-B
11.07.2024 00:36:44
HenryHolzwurm
Hallo Zusammen,
Bitte verzeiht mein langes Schweigen. Neben einem Urlaub hat mich dann leider auch die Arbeit doch mehr gefordert, als es mir lieb ist.
Ich habe mich jetzt etwas mehr mit Euren Lösungen befasst und bin schon einmal ein gutes Stück weiter gekommen. Vielen Dank schon einmal dafür.
Für die folgende Frage habe ich auch die zwei Beispieldateien hochgeladen, um die es mir geht. (Hoffe das hat geklappt,....)
Template 1: https://www.herber.de/bbs/user/170839.xlsm
Template 2: https://www.herber.de/bbs/user/170840.xlsx
In dem Macro (Template 1) müsste nur am Anfang der entsprechende Dateipfad noch ergänzt werden, um (bei Ausführung des Makros) ein entsprechendes DropDown Menü zu öffnen und "Template 2" auszuwählen.
Long storry short:
Template 1 beinhaltet das Macro
Template 1 - Tabelle 2: Beinhaltet meine "Hauptliste", mit der ich abgleichen und die ich im Bedarfsfall ergänzen möchte
Template 2 - Tabelle 1: Das ist der Datensatz, aus dem ich einzelne Zeilen im Bedarfsfall übertragen möchte.
Der Bedarfsfall ergibt sich wie folgt:
Ist der Wert in "Template 2 - Tabelle 1 - Spalte 1" noch nicht in "Template 1 - Tabelle 2 -Spalte 2" enthalten, dann sollen alle Werte der zugehörigen Zeile aus "Template 2 - Tabelle 1" in die nächste freie Zeile in "Template 1 - Tabelle 2", mit einer Zelle nach rechts verschoben ergänzt werden.
etwas anschaulicher formuliert: Stehen sich also zum Beispiel diese Werte gegenüber:
Template 2 - Tabelle 1 - Spalte 1: 1,5,8,10,23,56
Template 1 - Tabelle 2 -Spalte 2: 1,5,23,56,33
Hier möchte ich dann also die Werte aus den Zeilen mit den Werten 8,10 und 23 in Template 1 einfügen
Aktuell kommt es schon so irgendwie zu einer Eintragung, aber weder "erwische" ich die Positionen in meinem Array, die ich wirklich übertragen will, noch werden alle in Frage kommenden Werte eingetragen und um das richtige Sheet für die Eintragung habe ich mich bisher noch nciht gekümmert und war froh, überhaupt etwas eingetragen zu bekommen,.....
Könnt Ihr mir hier bitte nochmal helfen?
Den kompletten Code Füge ich hier nochmal mit ein, sollte ich mich bereits im Vorfeld komplett verrannt haben......Ich sehe meine Probleme aber im unteren Bereich des Codes. Also unter dem letzten '--------------------------------'
Vielen Dank Euch allen schon einmal im Vorraus.
Euer Henry
Sub ImportDataAs_Array()
' Variables used for Source sheet
Dim rngDataSource As Range
Dim arrSource As Variant
Dim wbSource As Workbook
ChDrive ("C:\")
ChDir ("C:\Desktop\Sandbox\") 'Hier den Dateipfad eintragen, aus dem der Ordner geöffnet werden soll.
' Variables used for Target sheet
Dim rngDataTarget As Range
Dim arrTarget As Variant
' Variables for LoopComparison, File updating and noting
Dim int_ArrayPosSourceArray As Integer
Dim int_ArrayPosTargetArray As Integer
Dim int_ArrayValueSource As Integer
Dim int_ArrayValueTarget As Integer
Dim int_LastLine As Integer
'------------------------------------------------'
'Select source File
sSourceDirectory = Application.GetOpenFilename("(*.xls*), *.xls*")
' Open Read Extract and close source file in background
' Block PopUps and Screen Updating
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Open
Set wbSource = Workbooks.Open(sSourceDirectory)
'Define Data Set for Source / C4C report
'Range in Source File
Set rngDataSource = wbSource.Worksheets(1).Range("A1").CurrentRegion
' Redimension and fill array
ReDim arrSource(1 To rngDataSource.Rows.Count, 1 To rngDataSource.Columns.Count)
arrSource = rngDataSource.Value
' Close Souerce File
wbSource.Close SaveChanges:=False
' Enable PopUps and Screen Updating
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'------------------------------------------------'
'Define Data Set for Target / Just SO numbers from calendar
'Range in Target File
Set rngDataTarget = Tabelle2.Range("A1").CurrentRegion
' Redimension and fill array
ReDim arrTarget(1 To rngDataTarget.Rows.Count, 1 To rngDataTarget.Columns.Count)
arrTarget = rngDataTarget.Value
'------------------------------------------------'
'Compare the current Source position (SO Number) with all entries of the tartger array positions for SO Number.
' if existing, skip
' if not, enter and highlightValue read from arr Source
For int_ArrayPosSource = LBound(arrSource) To UBound(arrSource) - 1
int_ArrayValueSource = arrSource(int_ArrayPosSource + 1, 1)
For int_ArrayPosTarget = LBound(arrTarget) To UBound(arrTarget) - 1
int_ArrayValueTarget = arrTarget(int_ArrayPosTarget + 1, 2)
If int_ArrayValueSource = int_ArrayValueTarget Then Exit For
Next
If int_ArrayPosTarget > UBound(arrTarget) - 1 Then
int_LastLine = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(int_LastLine, 1).Value = ""
Cells(int_LastLine, 2).Value = arrSource(x + 1, 1)
Cells(int_LastLine, 3).Value = arrSource(x + 1, 2)
Cells(int_LastLine, 4).Value = arrSource(x + 1, 3)
Cells(int_LastLine, 5).Value = arrSource(x + 1, 4)
Cells(int_LastLine, 6).Value = arrSource(x + 1, 5)
Cells(int_LastLine, 7).Value = arrSource(x + 1, 6)
Cells(int_LastLine, 8).Value = arrSource(x + 1, 7)
Cells(int_LastLine, 9).Value = arrSource(x + 1, 8)
Cells(int_LastLine, 10).Value = arrSource(x + 1, 9)
Cells(int_LastLine, 11).Value = arrSource(x + 1, 10)
Cells(int_LastLine, 12).Value = arrSource(x + 1, 11)
Cells(int_LastLine, 13).Value = arrSource(x + 1, 12)
Cells(int_LastLine, 14).Value = arrSource(x + 1, 13)
End If
Next
End Sub