Anzeige
Archiv - Navigation
1916to1920
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Array zum Abgleich und Aktualisieren

Array zum Abgleich und Aktualisieren
23.01.2023 16:01:43
Manuel
Hallo zusammen,
ich erstelle gerade ein Tool, welches Daten von einem anderes System als Export verarbeitet und in einer "Master Product" Tabelle speichert.
Ablauf ist folgender:
- User kopiert in Tabellenblatt "Import Product GMBH" exportierte Daten (werde ich ggf. durch Auswahl des Exports in Zukunft nutzerfreundlicher machen, aber hier sehe ich kein Problem)
- User führt makro aus:
---Von Reihe 2 bis Ende durchgehen im Import Sheet. Jeweils Abgleich ob gleiches Produkt schon vorhanden (Spalte B "Import Product Gmbh" und Spalte A "Master Product")
---Wenn schon vorhanden (sprich gleiche Artikelnummer), dann Einträge aktualisieren sofern notwendig (Spalte B bis K in Spalte A bis J, in gleicher Reihenfolge)
---Wenn nicht vorhanden (sprich Artikelnr nicht gefunden) UND wenn Spalte I ist ein "Y" dann Eintrag am Ende der Master Product Liste erstellen (wieder Spalte B bis K in Spalte A bis J, in gleicher Reihenfolge)
Das wäre die Basis die ich gerne aufbauen möchte. Mit einem eigenen Makro habe ich das bereits geschafft und es funktioniert (code anbei in Modul 1). Zugegeben es könnte schöner sein, aber grundsätzlich geht es.
Jetzt stehe ich vor der Herausforderung, dass die Datenmenge zu groß ist (>4.000 Zeilen im Import (Tendenz steigend) und ~3.500 Zeilen in Master Product) und die Ausführung des Makros dauert zu lange. (gut wäre 10 min). In anderen Tabellenblättern (nicht im der Beispieldatei drin) gibt es einen Abgleich anderer Art über Arrays mit einer wesentlich besseren Performance. Leider klappt reverse engineering dazu nicht.
Kann mir jemand helfen das über Arrays anstatt Range zu lösen? Vielleicht kann mir dazu ja jemand helfen? Ansonsten starte ich mit dem ursprünglichen Makro nochmal neu (ist leider ein Projekt was schon ein paar mal umgebaut wurde)
https://www.herber.de/bbs/user/157428.xlsm
Gruß

26
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Array zum Abgleich und Aktualisieren
23.01.2023 16:22:10
onur
Und du bist wirklich sicher, dass das Makro funktioniert?
Dim importArray As Variant
Dim masterArray As Variant
lRowArrayRange = UBound(masterarrey, 1) - LBound(masterarrey, 1) + 1
lColArrayRange = UBound(masterarrey, 2) - LBound(masterarrey, 2) + 1
AW: Array zum Abgleich und Aktualisieren
23.01.2023 16:27:43
Manuel
entschuldige bitte @onur
das Upload war natürlich murks. bzw. nicht richtig aufgeräumt.
Sub CompareAndCopy() kann weg, das war eine Spielerei.
Als Modul 1 habe ich einen neuen Code geschrieben, der etwas sauberere ist als die alte Version, aber immernoch nicht sehr schnell
Sub UpdateMasterProductList()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim importSheet As Worksheet
    Set importSheet = ThisWorkbook.Sheets("Import Product GMBH")
    Dim masterSheet As Worksheet
    Set masterSheet = ThisWorkbook.Sheets("Master product")
    Dim lastImportRow As Long
    lastImportRow = importSheet.Cells(importSheet.Rows.Count, "B").End(xlUp).Row
    Dim lastMasterRow As Long
    lastMasterRow = masterSheet.Cells(masterSheet.Rows.Count, "A").End(xlUp).Row + 1
    
    iCounter = 1
    lngAnz = lastImportRow
                    
    'importSheet.Range("B:B").NumberFormat = "@"
    'masterSheet.Range("A:A").NumberFormat = "@"
    
    Dim i As Long 'reihe im Import
    For i = 2 To lastImportRow
        ' Überprüfen, ob die Artikelnummer bereits in der Master-Liste vorhanden ist
        Dim artNr As String
        artNr = importSheet.Cells(i, "B").Value
        Dim matchRow As Variant
        'matchRow = Application.Match(artNr, masterSheet.Range("A:A"), 0)
        'matchRow = Application.VLookup(artNr, masterSheet.Range("A:A"), 1, False)
        Set c = masterSheet.Range("A:A").Find(artNr, LookIn:=xlValues, LookAt:=xlWhole)
        
        'If Not IsError(matchRow) Then
            
        If Not c Is Nothing Then
           
            ' Artikelnummer gefunden, überprüfen und aktualisieren Sie die Einträge
            Dim j As Long 'spalte in Master
            For j = 1 To 10
                If importSheet.Cells(i, j + 1).Value > masterSheet.Cells(c.Row, j).Value Then
                    masterSheet.Cells(c.Row, j).Value = importSheet.Cells(i, j + 1).Value
                End If
            Next j
        Else
        
            ' Artikelnummer nicht gefunden, überprüfen Sie, ob ein neuer Eintrag erstellt werden soll
            If importSheet.Cells(i, 9).Value = "Y" Then
                ' Neuer Eintrag am Ende der Master-Liste hinzufügen
                For j = 1 To 11
                    masterSheet.Cells(lastMasterRow, j).Value = importSheet.Cells(i, j + 1).Value
                    
                Next j
                lastMasterRow = masterSheet.Cells(masterSheet.Rows.Count, "A").End(xlUp).Row + 1
                
            End If
        End If
StatusAnzeige "Fortschritt: ", iCounter / lngAnz, artNr
 iCounter = iCounter + 1
        
    Next i
MsgBox "done komplett"
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
Private Function StatusAnzeige(sTxt As String, sWert As Single, Product As String)
'** Sub um Fortschritt in Statusleiste in Excel anzuzeigen
Dim iWert As Integer, iWiederh As Integer
With WorksheetFunction
  iWert = .Round(sWert, 2) * 100
  iWiederh = Int(iWert / 1000)
  Application.StatusBar = sTxt & .Rept("", 1000 - iWiederh) & "" & iWert & "%" & _
    " " & .Rept(Chr(149), iWiederh) & " Aktueller Artikel: " & Product
    
End With
End Function

Anzeige
AW: Array zum Abgleich und Aktualisieren
23.01.2023 16:35:26
onur
1) Soll ich jetzt deins Makro in Deine Datei selbst einbauen?
2) Ich brauche jede Menge (Pseudo-) Testdaten, um die Geschwindigkeit zu prüfen und anzupassen.
AW: Array zum Abgleich und Aktualisieren
23.01.2023 16:54:45
Manuel
Hallo Onur,
Hier die neue Datei.
https://www.herber.de/bbs/user/157430.xlsm
Mehr Testdaten konnte ich nicht reinpacken wegen der Größenbeschränkung. Aber lassen sich nach unten erweitern. Die Struktur der Daten ändert sich nicht.
AW: Array zum Abgleich und Aktualisieren
23.01.2023 16:59:49
onur
Wie lang braucht dein Rechner bei dieser Datei?
AW: Array zum Abgleich und Aktualisieren
23.01.2023 17:15:18
Manuel
Beim Durchlauf mit leeren Master Product Sheet etwa 13 min. Beim realen Datensatz (mehr Daten) sind es mit identischem Makro etwa 20 min (und der Datensatz wächst)
Anzeige
AW: Array zum Abgleich und Aktualisieren
23.01.2023 17:16:53
onur
Ich meinte die Datei, die du gepostet hast.
Meiner braucht 16 sec.
AW: Array zum Abgleich und Aktualisieren
23.01.2023 17:21:48
Manuel
Ich habe exakt die Datei die ich gepostet habe genommen.
Sonst habe ich keine Probleme mit der Geschwindigkeit etc. Der Rechner ist auch nicht stark ausgelastet.
Woran kann das liegen?
AW: Array zum Abgleich und Aktualisieren
23.01.2023 17:24:17
onur
Welche Windows- und Excelversion? Und wieviel Bit? 32 oder 64?
Wieviel Speicher?
AW: Array zum Abgleich und Aktualisieren
23.01.2023 17:32:30
Manuel
Excel über 365 (Version 16)
64 bit mit 8,00 GB RAM
Intel(R) Core(TM) i5-10210U CPU @ 1.60GHz 2.10 GHz
typisher lenovo bürorechner
AW: Array zum Abgleich und Aktualisieren
23.01.2023 16:58:36
Rudi
Hallo,
teste mal:
Sub Abgleich()
  Dim vntImport, vntMaster, Tmp, vntOut()
  Dim i As Long, j As Integer
  Dim objNeu As Object, objMaster As Object, oObj
  Dim strTmp As String
  
  Const cstrDELIM As String = "|"
  
  Set objMaster = CreateObject("scripting.dictionary")
  
  With Sheets("Import Product GMBH")
    vntImport = .Range(.Cells(2, 2), .Cells(Rows.Count, 2).End(xlUp)).Resize(, 10)
  End With
  
  With Sheets("Master Product")
    vntMaster = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Resize(, 16)
  End With
  
  For i = 1 To UBound(vntMaster)
    objMaster(vntMaster(i, 1)) = vntMaster(i, 1)
    For j = 2 To UBound(vntMaster, 2)
      objMaster(vntMaster(i, 1)) = objMaster(vntMaster(i, 1)) & cstrDELIM & vntMaster(i, j)
    Next j
  Next i
  
  For i = 1 To UBound(vntImport)
    If objMaster.exists(vntImport(i, 1)) Then
      Tmp = Split(objMaster(vntImport(i, 1)), cstrDELIM)
      For j = 1 To 10
        Tmp(j - 1) = vntImport(i, j)
      Next j
      objMaster(vntImport(i, 1)) = Join(Tmp, cstrDELIM)
    Else
      objMaster(vntImport(i, 1)) = vntImport(i, 1)
      For j = 2 To UBound(vntImport, 2)
        objMaster(vntImport(i, 1)) = objMaster(vntImport(i, 1)) & cstrDELIM & vntImport(i, j)
      Next j
      For j = 11 To 16
        objMaster(vntImport(i, 1)) = objMaster(vntImport(i, 1)) & cstrDELIM
      Next j
    End If
  Next i
  
    i = 0
    ReDim vntOut(1 To objMaster.Count, 1 To 16)
    For Each oObj In objMaster
      i = i + 1
      Tmp = Split(objMaster(oObj), cstrDELIM)
      For j = 0 To 15
        If IsNumeric(Tmp(j)) Then
          vntOut(i, j + 1) = Tmp(j) * 1
        Else
          vntOut(i, j + 1) = Tmp(j)
        End If
      Next j
    Next oObj
    
    With Sheets("Master Product")
      .Cells(2, 1).Resize(UBound(vntOut), 16) = vntOut
    End With
  
End Sub
Gruß
Rudi
Anzeige
AW: Array zum Abgleich und Aktualisieren
23.01.2023 17:18:25
Manuel
Hallo Rudi,
vielen Dank!
das geht beim Initalien durchlauf ja schonmal ratz fatz. Ein paar Sachen passen leider noch nicht:
- in Zeile 2 werden nochmal die Tabellenüberschriften gespeichert
- Zeile 3 ist dann leer. Zeile 4 fangen dann die Daten an
- es werden alle Artikel übertragen, nicht nur die mit Y in Spalte I
- Bei einer Aktualisierung werden die Daten nur unten angehängt, nicht aktualisiert
Gruß Mirko
AW: Array zum Abgleich und Aktualisieren
23.01.2023 19:18:41
Yal
Hallo Manuel,
Ich hatte zuerst den Code von Rudi nicht zurecht verstanden, aber auf dem Weg zu meiner eigenen Lösung festgestellt, dass wir genau dieselbe Strategie folgen.
Da ich nicht über den Umweg der Array gehe, komme ich auf etwas kompakteres, was aber leicht länger laufen dürfte.
Deine Anmerkungen sollten -ich hoffe- berücksichtigt sein. Beachte, dass der Vorgang der Inhalt von "Master" überschreibt, also nicht auf das Original abspielen.
Sub Abgleich_Yal()
Dim Dic As Object
Dim Z, i
    Set Dic = CreateObject("scripting.dictionary")
'Vorhandenes "merken"
    With Sheets("Master Product")
        For Each Z In .Range(.Cells(2, "A"), .Cells(Rows.Count, "A").End(xlUp))
            Dic(Z.Value) = Z.Row
        Next
    End With
'neues lesen und entw. Ändern oder hinzufügen
    Application.ScreenUpdating = False 'zum Testzweck auskommentieren!
    With Sheets("Import Product GMBH")
        For Each Z In .Range(.Cells(2, "B"), .Cells(Rows.Count, "B").End(xlUp))
            If Dic.Exists(Z.Value) Then
                Sheets("Master Product").Cells(Dic(Z.Value), 1).Resize(1, 10) = Z.Resize(1, 10).Value
            Else
                If Z.Offset(0, 7).Value = "Y" Then _
                    Sheets("Master Product").Range("A99999").End(xlUp).Offset(1, 0).Resize(1, 16) = Z.Resize(1, 16).Value
            End If
        Next
    End With
    Set Dic = Nothing
    Application.ScreenUpdating = True
End Sub
VG
Yal
Anzeige
AW: Array zum Abgleich und Aktualisieren
23.01.2023 22:11:00
Manuel
Hi Yal,
Vielen Dank. Bin beeindruckt von der Kompaktheit!
Auf ein Problem bin ich noch gestoßen: Bei einem erneuten Durchgang wird der Import unter die vorhandenen Zeile geschrieben, oder soll ich die Tabelle vorab leeren?
AW: Array zum Abgleich und Aktualisieren
23.01.2023 23:01:04
Yal
Hallo Manuel,
bei erneutem Lauf auf gleiche Quelle passiert nichts: Einträge, die beim ersten Lauf nicht bekannt waren, sind unten hinzugefügt worden und dementsprechend beim zweiten Lauf bereits da.
Wir vorher gesagt, der Umfang von "Master" bleibt auf alle Fälle bestehen und es kommt aus Import die Zeilen mit"Y" dazu.
VG
Yal
AW: Array zum Abgleich und Aktualisieren
24.01.2023 11:51:22
Manuel
Hi Yal,
Ich habe leider den Fehler, dass im Master Artikel doppelt eingefügt werden, anstatt das gar nichts passiert.
Was habe ich gemacht:
- Neu die Beispielmappe runtergeladen: https://www.herber.de/bbs/user/157430.xlsm
- Dein Makro als Modul 2 eingefügt und zwei ausgeführt
- in Master Product siehst du dass es doppelte Produkte gibt (bedingte Formartierung in Spalte A). Eigentlich sollte es ja keine Updates geben, wenn keine Änderungen am Import vorgenommen wurden. hier habe ich mal das Ergebnis nach den beiden Runs hochgeladen: https://www.herber.de/bbs/user/157442.xlsm
Anzeige
AW: Array zum Abgleich und Aktualisieren
24.01.2023 13:27:14
Rudi
Hallo,
Problem erkannt und beseitigt:
 Sub Abgleich()
    Dim vntImport, vntMaster, Tmp, vntOut()
    Dim i As Long, j As Integer
    Dim objNeu As Object, objMaster As Object, oObj
    Dim strTmp As String, strKEY As String
    
    Const cstrDELIM As String = "|"
    
    Set objMaster = CreateObject("scripting.dictionary")
    
    With Sheets("Import Product GMBH")
      vntImport = .Range(.Cells(2, 2), .Cells(Rows.Count, 2).End(xlUp)).Resize(, 10)
    End With
    
    With Sheets("Master Product")
      vntMaster = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Resize(, 16)
    End With
    
    For i = 1 To UBound(vntMaster)
      strKEY = CStr(vntMaster(i, 1))
      objMaster(strKEY) = strKEY
      For j = 2 To UBound(vntMaster, 2)
        objMaster(strKEY) = objMaster(strKEY) & cstrDELIM & vntMaster(i, j)
      Next j
    Next i
    
    For i = 1 To UBound(vntImport)
      strKEY = CStr(vntImport(i, 1))
      If objMaster.exists(strKEY) Then
        Tmp = Split(objMaster(strKEY), cstrDELIM)
        For j = 2 To 10
          Tmp(j - 1) = vntImport(i, j)
        Next j
        objMaster(strKEY) = Join(Tmp, cstrDELIM)
      Else
        If vntImport(i, 8) = "Y" Then
          objMaster(strKEY) = strKEY
          For j = 2 To UBound(vntImport, 2)
            objMaster(strKEY) = objMaster(strKEY) & cstrDELIM & vntImport(i, j)
          Next j
          For j = 11 To 16
            objMaster(strKEY) = objMaster(strKEY) & cstrDELIM
          Next j
        End If
      End If
    Next i
    
      i = 0
      ReDim vntOut(1 To objMaster.Count, 1 To 16)
      For Each oObj In objMaster
        i = i + 1
        Tmp = Split(objMaster(oObj), cstrDELIM)
        For j = 0 To 15
          If IsNumeric(Tmp(j)) Then
            vntOut(i, j + 1) = Tmp(j) * 1
          Else
            vntOut(i, j + 1) = Tmp(j)
          End If
        Next j
      Next oObj
      
      With Sheets("Master Product")
        .Cells(2, 1).Resize(UBound(vntOut), 16) = vntOut
        .Activate
      End With
    
  End Sub
Gruß
Rudi
Anzeige
AW: Array zum Abgleich und Aktualisieren
24.01.2023 15:59:52
Manuel
Hi Rudi,
Merci! Klappt super!
Eine kleine Änderung habe ich vorgenommen, wo ich noch nicht verstehe wieso.
Wie gesagt habe ich(immernoch) das Problem das in deiner Version Die Zeile 2 mit den Werten aus Zeile 1 (Die Spaltenüberschriften) und Zeile 3 leer ist.
Ich habe jetzt den folgenden Teil auf i = 3 geändert. Dann passt die Ausgabe entsprechend.
...
For i = 3 To UBound(vntMaster)
      strKEY = CStr(vntMaster(i, 1))
      objMaster(strKEY) = strKEY
      For j = 2 To UBound(vntMaster, 2)
        objMaster(strKEY) = objMaster(strKEY) & cstrDELIM & vntMaster(i, j)
      Next j
    Next i
...

Anzeige
verstehe ich auch nicht
25.01.2023 09:41:10
Rudi
Hallo,
kann ich nicht nachvollziehen.
Mir ist aber noch was aufgefallen:
Was ist denn, wenn bei einem in Master existierenden Artikel in Import kein Y in I ist? bislang wird einfach der neue Wert (N) in Master geschrieben.
Wenn er entfernt werden soll:
    For i = 1 To UBound(vntImport)
      strKEY = CStr(vntImport(i, 1))
      If objMaster.exists(strKEY) Then
        If vntImport(i, 8) = "Y" Then
          Tmp = Split(objMaster(strKEY), cstrDELIM)
          For j = 2 To 10
            Tmp(j - 1) = vntImport(i, j)
          Next j
          objMaster(strKEY) = Join(Tmp, cstrDELIM)
        Else
          objMaster.Remove (strKEY)
        End If
      Else
        If vntImport(i, 8) = "Y" Then
          objMaster(strKEY) = strKEY
          For j = 2 To UBound(vntImport, 2)
            objMaster(strKEY) = objMaster(strKEY) & cstrDELIM & vntImport(i, j)
          Next j
          For j = 11 To 16
            objMaster(strKEY) = objMaster(strKEY) & cstrDELIM
          Next j
        End If
      End If
    Next i
Gruß
Rudi
Anzeige
AW: verstehe ich auch nicht
01.02.2023 09:26:30
Manuel
Hallo Rudi,
"Was ist denn, wenn bei einem in Master existierenden Artikel in Import kein Y in I ist? bislang wird einfach der neue Wert (N) in Master geschrieben."
--> Der Wert bleibt dann ganz normal bestehen. War also schon richtig so.
Klappt inzwischen super! (mit der Anpassung die ich zuvor gepostet hatte) bzgl. der doppelte Überschriftzeile
Eine Frage habe ich noch:
Ich würde nun noch gerne für jeden Eintrag aus Master mit einem dritten Blatt ("Import INC" - gleicher Aufbau wie Import Gmbh) abgleichen.
Und wenn Eintrag gefunden (Sprich wieder Spalte B in Import und Spalte A in Master identisch) dann
jeweils von Import zu Master
Spalte E zu Spalte L und
Spalte J zu Spalte K
damit klappt das Ganze, oder habe ich hier irgendeinen Schnitzer gemacht? Habe versucht deinen Code so gut es geht nachzuvollziehen
Sub Abgleich_GMBH_and_INC()
     Dim vntImport, vntMaster, Tmp, vntOut(), vntImportInc
     Dim i As Long, j As Integer
     Dim objNeu As Object, objMaster As Object, oObj
     Dim strTmp As String, strKEY As String, strKEYINC As String
     
     
     Const cstrDELIM As String = "|"
     
     Set objMaster = CreateObject("scripting.dictionary")
     
     
     
     With Sheets("Import Product GMBH")
       vntImport = .Range(.Cells(2, 2), .Cells(Rows.Count, 2).End(xlUp)).Resize(, 10)
     End With
     
      With Sheets("Import Product Inc")
       vntImportInc = .Range(.Cells(2, 2), .Cells(Rows.Count, 2).End(xlUp)).Resize(, 10)
     End With
     
     With Sheets("Master Product")
       vntMaster = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Resize(, 16)
     End With
     
     For i = 3 To UBound(vntMaster)
       strKEY = CStr(vntMaster(i, 1))
       objMaster(strKEY) = strKEY
       For j = 2 To UBound(vntMaster, 2)
         objMaster(strKEY) = objMaster(strKEY) & cstrDELIM & vntMaster(i, j)
       Next j
     Next i
     
     For i = 1 To UBound(vntImport)
       strKEY = CStr(vntImport(i, 1))
       If objMaster.exists(strKEY) Then
         Tmp = Split(objMaster(strKEY), cstrDELIM)
         For j = 2 To 10
           Tmp(j - 1) = vntImport(i, j)
         Next j
         objMaster(strKEY) = Join(Tmp, cstrDELIM)
       Else
         If vntImport(i, 8) = "Y" Then
           objMaster(strKEY) = strKEY
           For j = 2 To UBound(vntImport, 2)
             objMaster(strKEY) = objMaster(strKEY) & cstrDELIM & vntImport(i, j)
           Next j
           For j = 11 To 16
             objMaster(strKEY) = objMaster(strKEY) & cstrDELIM
           Next j
         End If
       End If
     Next i
     
     
     For i = 1 To UBound(vntImportInc)
       strKEY = CStr(vntImportInc(i, 1))
       If objMaster.exists(strKEY) Then
         Tmp = Split(objMaster(strKEY), cstrDELIM)
  
           Tmp(10) = vntImportInc(i, 9)
           Tmp(11) = vntImportInc(i, 4)
 
         objMaster(strKEY) = Join(Tmp, cstrDELIM)
       Else
        
       End If
     Next i
     
       i = 0
       ReDim vntOut(1 To objMaster.Count, 1 To 16)
       For Each oObj In objMaster
         i = i + 1
         Tmp = Split(objMaster(oObj), cstrDELIM)
         For j = 0 To 15
           If IsNumeric(Tmp(j)) Then
             vntOut(i, j + 1) = Tmp(j) * 1
           Else
             vntOut(i, j + 1) = Tmp(j)
           End If
         Next j
       Next oObj
       
       With Sheets("Master Product")
         .Cells(2, 1).Resize(UBound(vntOut), 16) = vntOut
         .Activate
       End With
     
   End Sub

Anzeige
AW: Array zum Abgleich und Aktualisieren
23.01.2023 20:02:55
Rudi
Hallo,
die ersten beiden Punkte kann ich nicht nachvollziehen.
zu 4: Wenn Artikel vorhanden, werden B:K mit den Importdaten überschrieben
Nur Y in I (Webshop active)
  Sub Abgleich()
    Dim vntImport, vntMaster, Tmp, vntOut()
    Dim i As Long, j As Integer
    Dim objNeu As Object, objMaster As Object, oObj
    Dim strTmp As String
    
    Const cstrDELIM As String = "|"
    
    Set objMaster = CreateObject("scripting.dictionary")
    
    With Sheets("Import Product GMBH")
      vntImport = .Range(.Cells(2, 2), .Cells(Rows.Count, 2).End(xlUp)).Resize(, 10)
    End With
    
    With Sheets("Master Product")
      vntMaster = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Resize(, 16)
    End With
    
    For i = 1 To UBound(vntMaster)
      objMaster(vntMaster(i, 1)) = vntMaster(i, 1)
      For j = 2 To UBound(vntMaster, 2)
        objMaster(vntMaster(i, 1)) = objMaster(vntMaster(i, 1)) & cstrDELIM & vntMaster(i, j)
      Next j
    Next i
    
    For i = 1 To UBound(vntImport)
      If objMaster.exists(vntImport(i, 1)) Then
        Tmp = Split(objMaster(vntImport(i, 1)), cstrDELIM)
        For j = 2 To 10
          Tmp(j - 1) = vntImport(i, j)
        Next j
        objMaster(vntImport(i, 1)) = Join(Tmp, cstrDELIM)
      Else
        If vntImport(i, 8) = "Y" Then
          objMaster(vntImport(i, 1)) = vntImport(i, 1)
          For j = 2 To UBound(vntImport, 2)
            objMaster(vntImport(i, 1)) = objMaster(vntImport(i, 1)) & cstrDELIM & vntImport(i, j)
          Next j
          For j = 11 To 16
            objMaster(vntImport(i, 1)) = objMaster(vntImport(i, 1)) & cstrDELIM
          Next j
        End If
      End If
    Next i
    
      i = 0
      ReDim vntOut(1 To objMaster.Count, 1 To 16)
      For Each oObj In objMaster
        i = i + 1
        Tmp = Split(objMaster(oObj), cstrDELIM)
        For j = 0 To 15
          If IsNumeric(Tmp(j)) Then
            vntOut(i, j + 1) = Tmp(j) * 1
          Else
            vntOut(i, j + 1) = Tmp(j)
          End If
        Next j
      Next oObj
      
      With Sheets("Master Product")
        .Cells(2, 1).Resize(UBound(vntOut), 16) = vntOut
        .Activate
      End With
    
  End Sub
Gruß
Rudi
AW: Array zum Abgleich und Aktualisieren
24.01.2023 10:29:07
snb
Den Codename von 'Master' habe ich umbenennt in 'sheet0'.
Sub M_snb()
   sn = sheet0.ListObjects(1).DataBodyRange
   sp = Tabelle1.ListObjects(1).DataBodyRange
   
   With CreateObject("scripting.dictionary")
     For j = 1 To UBound(sn)
       .Item(sn(j, 2)) = j
     Next
     For j = 1 To UBound(sp)
       If .exists(sp(j, 3)) Then
          y = .Item(sp(j, 3))
          For jj = 2 To UBound(sp, 2)
             sn(y, jj - 1) = sp(j, jj)
          Next
       Else
          sheet0.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 10) = Array(sp(j, 2), sp(j, 3), sp(j, 4), sp(j, 5), sp(j, 6), sp(j, 7), sp(j, 8), sp(j, 9), sp(j, 10), sp(j, 11))
       End If
     Next
      sheet0.ListObjects(1).DataBodyRange.Resize(UBound(sn)) = sn
   End With
End Sub

AW: Array zum Abgleich und Aktualisieren
23.01.2023 18:06:07
Yal
Hallo Manuel,
verstehe ich das richtig: Du hast eine Liste von neue Datensätze "Import" und eine vorhandene Liste "Master". Die beide Listen haben genau dieselbe Struktur (Gleiche Spaltennamen und Inhalt).
Du willst zusammenbringen:
_ alles aus Import
_ alles aus Master, was nicht bereit in Import ist.
Es sind eigentlich 2 Outer join, die dann zusammengefügt werden. Es sollte dann in Power Query nur ein paar Klicks sein, Datei-Import inklusiv.
Siehe https://excelhero.de/power-query/power-query-ganz-einfach-erklaert
VG
Yal
AW: Array zum Abgleich und Aktualisieren
23.01.2023 20:47:58
Manuel
Hi Yal,
Danke für den Denkanstoß. Habe noch nicht viel damit gemacht. Werde mich mal einlesen.
Es gibt noch zwei andere Bedingungen die dazukommen
_ alles aus Import
_ _ _ alles aus Import was in Spalte I "Y" hat
_ alles aus Master, was nicht bereit in Import ist.
_ _ _ das hier verstehe ich nicht ganz. Möchte die Einträge im Master durch gleiche Einträge im Import ersetzen (gleicher Wert in Spalte A bzw B)
Eher der anderen Beitrag betrachten
23.01.2023 23:06:05
Yal
Hallo Manuel,
ich habe zuerst diese Idee hier im Lauf gebracht aber die Rahmenbedingung erst auf Basis der Lösung von Rudi (nicht selten eine gute Inspiration :-) genau unter die Lupe genommen.
Daher eher der andere Beitrag betrachten.
Einer Lösung mit Power Query wäre trotzdem machbar und sogar sinnvoll, weil die Datei aus Salesforce nicht zuerst in Excel importiert werden müsste.
VG
Yal
AW: Array zum Abgleich und Aktualisieren
24.01.2023 11:36:18
snb
Verwende 'Dictionary':
NB. 'Master' sheet codename= 'sheet0'
Sub M_snb()
   sn = sheet0.ListObjects(1).DataBodyRange
   sp = Tabelle1.ListObjects(1).DataBodyRange
   
   With CreateObject("scripting.dictionary")
     For j = 1 To UBound(sn)
       .Item(sn(j, 2)) = Application.Index(sn, j)
     Next
     For j = 1 To UBound(sp)
       If .exists(sp(j, 3)) Then
          st = .Item(sn(j, 2))
          For jj = 2 To UBound(sp, 2)
             st(jj - 1) = sp(j, jj)
          Next
          .Item(sp(j, 3)) = st
       Else
          .Item(sp(j, 3)) = Array(sp(j, 2), sp(j, 3), sp(j, 4), sp(j, 5), sp(j, 6), sp(j, 7), sp(j, 8), sp(j, 9), sp(j, 10), sp(j, 11), "", "", "", "", "", "")
       End If
     Next
      sheet0.ListObjects(1).DataBodyRange.Resize(.Count) = Application.Index(.items, 0, 0)
   End With
End Sub

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige