2 Arrays prüfen und neu zusammenfügen

Moderator: ModerationP

2 Arrays prüfen und neu zusammenfügen

Beitragvon Vulkanier » 02. Dez 2020, 22:51

n'abend Leute,
Meine Situation ist wie folgt, ich lese 2 arrays ein.
Code: Alles auswählen
'Array-1
With Workbooks("Kunden.xlsm").Worksheets(1)
rletzte = .Cells(Rows.Count, 1).End(xlUp).Row
arrtmp1 = .Range(.Cells(2, 1), .Cells(rletzte, 2))
End With
'+++++++++++++++++++++++++
'Array-2
With Workbooks("artikel.xlsm").Worksheets(1)
rletzte = .Cells(Rows.Count, 1).End(xlUp).Row
arrtmp = .Range(.Cells(2, 1), .Cells(rletzte, 10))

Array-1: 2Spalten einer Tabelle mit KundenNr. und KundenName
Array-2: 10Spalten einer Tabelle mit Kundennr. und weiteren Daten (Array-2 hat mehr Datensaetze als Array-1)
Nun möchte ich die 2 Arrays miteinander prüfen, wenn in Array-2 die gleiche KundenNr. gefunden wird soll diese durch den KundenNamen von Array-1 ersetzt werden
Anschliessend soll das Array-2 neu zusammengefügt werden, 1Spalte KundenNamen und 9Spalten mit weiteren Daten.

Könnt Ihr mir mit der umsetzung helfen.

LG
Man muss viel gelernt haben, um über das, was man nicht weiß, fragen zu können.
(Jean-Jacques Rousseau)
Benutzeravatar
Vulkanier
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 86
Registriert: 31. Mär 2015, 07:06

Re: 2 Arrays prüfen und neu zusammenfügen

Beitragvon HKindler » 03. Dez 2020, 09:26

Hi,

ich halte das Ersetzen der Kundennummern durch Namen für keine gute Idee. Dann dadurch hast du nachher in deiner Spalte eine Mixtur aus Nummern und Namen. Das ist eine Katastrophe! Und was machst du, wenn du zwei verschiedene Peter Müller in deiner Datei hast? Daher: Behalte die Kundennummer auf alle Fälle bei und füge in deinem zweiten Blatt eine zusätzliche Spalte für den Namen ein.

Dort trägst du dann die Formel =WENNFEHLER(SVERWEIS(A2;[Kunden.xlsm]Tabelle1!$A$2:$B$100;2;FALSCH);"nicht vorhanden") ein und ziehst diese runter.

Da VBA nicht wirklich auf einen effizienten Umgang mit Arrays ausgelegt ist, sondern Arrays immer nur in Schleifen behandeln kann, ist so ein Vorgehen auch dafür sinnvoll. Zeichne es einfach mit dem Makrorecorder auf und du hast ein nettes Grundgerüst für eine Routine. Am Schluss list du dann das Ergebnis als Array2 ein.
Gruß,
Helmut

----------------------------
Windows 10 Enterprise (64 Bit) / Office 365 ProPlus (32 Bit)
Benutzeravatar
HKindler
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 5351
Registriert: 04. Jul 2013, 09:02

Re: 2 Arrays prüfen und neu zusammenfügen

Beitragvon snb » 03. Dez 2020, 10:26

Code: Alles auswählen
Sub M_snb()
    sn = Workbooks("Kunden.xlsm").Sheets(1).Cells(1).CurrentRegion.Resize(, 2)
    sp = Workbooks("artikel.xlsm").Sheets(1).Cells(1).CurrentRegion.Resize(, 11)
   
    With CreateObject("scripting.dictionary")
       For j = 2 To UBound(sn)
          .Item(sn(j, 1)) = sn(j, 2)
       Next
       For j = 2 To UBound(sp)
          sp(j, 11) = .Item(sp(j, 1))
       Next
    End With
   
    Workbooks("artikel.xlsm").Sheets(1).Cells(1).CurrentRegion.Resize(, 11) = sp
End Sub
snb
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 8198
Registriert: 25. Sep 2014, 16:37

Re: 2 Arrays prüfen und neu zusammenfügen

Beitragvon Vulkanier » 03. Dez 2020, 23:45

Hallo,
ich habe mein ziel
Anschliessend soll das Array-2 neu zusammengefügt werden, 1Spalte KundenNamen und 9Spalten mit weiteren Daten.

leider falsch beschrieben :roll: ; sorry
Ich möchte gern den neuen array wie folgt:
1Spalte Kundennr.(von Array-2) 2Spalte (der passende) KundenNamen(von Array-1) zur Kundennummer von Array-2 und 9Spalten mit weiteren Daten.

könntet Ihr mir zeigen wie der code dahingehend angepasst werden kann?

LG
Man muss viel gelernt haben, um über das, was man nicht weiß, fragen zu können.
(Jean-Jacques Rousseau)
Benutzeravatar
Vulkanier
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 86
Registriert: 31. Mär 2015, 07:06

Re: 2 Arrays prüfen und neu zusammenfügen

Beitragvon HKindler » 04. Dez 2020, 08:34

Hallo Mr. Vulkanier,

dann mach doch das, was ich vorgeschlagen habe. Zeichne es mit dem Makroeditor auf und nach etwas Überarbeitung (Select & Co. entfernen, dynamisieren etc.) hast du dein Makro.

Du kannst das aufgezeichnete Makro auch gerne hier hoch laden, falls du Schwierigkeiten mit dem Überarbeiten hast.
Gruß,
Helmut

----------------------------
Windows 10 Enterprise (64 Bit) / Office 365 ProPlus (32 Bit)
Benutzeravatar
HKindler
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 5351
Registriert: 04. Jul 2013, 09:02

Re: 2 Arrays prüfen und neu zusammenfügen

Beitragvon snb » 04. Dez 2020, 10:13

Code: Alles auswählen
Sub M_snb()
  sn = Workbooks("Kunden.xlsm").Sheets(1).Cells(1).CurrentRegion.Resize(, 2)
  sp = Workbooks("artikel.xlsm").Sheets(1).Cells(1).CurrentRegion.Resize(, 11)
       
  With CreateObject("scripting.dictionary")
    For j = 2 To UBound(sn)
      .Item(sn(j, 1)) = sn(j, 2)
    Next
    For j = 2 To UBound(sp)
      sp(j, 11) = .Item(sp(j, 1))
    Next
  End With
       
  Workbooks("artikel.xlsm").Sheets(1).Cells(1).CurrentRegion.Resize(, 11).offset(,20) = application.index(sp,[row(1:400)],array(1,11,2,3,4,5,6,7,8,9,10))
End Sub
snb
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 8198
Registriert: 25. Sep 2014, 16:37

Re: 2 Arrays prüfen und neu zusammenfügen

Beitragvon Vulkanier » 11. Dez 2020, 01:08

Hallo,
@snb
bin leider erst heute dazu gekommen deinen code zu testen.
Allerdings macht der code nicht ganz was er soll :oops:
Soll:
Wenn Tabelle"Artikel-Spalte2"=TabelleKunde-Spalte1" dann soll in Tabelle"Artikel" eine neue Spalte zwischen 1 und 2 eingefügt werden mit dem inhalt vonTabelle"Kunde-Spalte2"
(Prüfung:
IF Tabelle"Kunde.Kdnr.(Spalte1)"=Tabelle"Artikel.Kdnr.(spalte1)" then
Tabelle"Artikel.neueSpalte" = Tabelle"Kunde-Kdname"(spalte2)
End IF

In deinem neu erzeugten Array müsste der 2.wert (11) dann den Kd.Namen von Tabelle"Kunde-Spalte2" in abhängigkeit von Tabelle"Artikel-Spalte1" enthalten.
Könntest du mir zeigen wie man das anpassen kann?

LG
Man muss viel gelernt haben, um über das, was man nicht weiß, fragen zu können.
(Jean-Jacques Rousseau)
Benutzeravatar
Vulkanier
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 86
Registriert: 31. Mär 2015, 07:06

Re: 2 Arrays prüfen und neu zusammenfügen

Beitragvon snb » 11. Dez 2020, 10:52

Wo ist deine Bespieldatei mit eingetragene Wünschergebnis ?
snb
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 8198
Registriert: 25. Sep 2014, 16:37

Re: 2 Arrays prüfen und neu zusammenfügen

Beitragvon Vulkanier » 11. Dez 2020, 23:49

Hallo,
Test datei im Anhang, mit Wunsch zettel.
LG
Du hast keine ausreichende Berechtigung, um die Dateianhänge dieses Beitrags anzusehen.
Man muss viel gelernt haben, um über das, was man nicht weiß, fragen zu können.
(Jean-Jacques Rousseau)
Benutzeravatar
Vulkanier
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 86
Registriert: 31. Mär 2015, 07:06

Re: 2 Arrays prüfen und neu zusammenfügen

Beitragvon 1Matthias » 12. Dez 2020, 17:45

Moin!
Ich hätte mal snb's Code ein wenig abgeändert. In seiner Variante müsstest du die Zeile mit dem application.index an die .list eigenschaft zuweisen. Das gibt bei der Variante aber das Problem, dass es dann 400 Zeilen in der LB sind. Man könnte jetzt das im INdex anpassen (geht m.W. aber nur über emulate). HAbe deshalb am Anfang eine Spalte B hinzugefügt, dann den Bereich ausgelesen und die Spalte wieder gelöscht. Damit hat man schon die erforderlichen Spalten. Die Einträge kann man so direkt in die betreffende Spalte schreiben und sparrt Index.
Einfach mal testen.
Code: Alles auswählen
Option Explicit
Private Sub UserForm_Initialize()
'On Error GoTo fehler
Dim rletzte As Long
Dim lngIndex As Long, temp
Dim sn, sp, j
Dim rng As Range
'Fenster ganzer Bildschirm
Me.Top = Application.Top
Me.Left = Application.Left
Me.Height = Application.Height
Me.Width = Application.Width
'******************************************

 sn = Workbooks("Kunden.xlsx").Sheets(1).Cells(1).CurrentRegion.Resize(, 2)
 Workbooks("artikel.xlsm").Sheets(1).Columns(2).Insert
  sp = Workbooks("artikel.xlsm").Sheets(1).Cells(1).CurrentRegion.Resize(, 11)
  Workbooks("artikel.xlsm").Sheets(1).Columns(2).Delete
 
 
  With CreateObject("scripting.dictionary")
    For j = 2 To UBound(sn)
      .Item(sn(j, 1)) = sn(j, 2)
    Next
    For j = 2 To UBound(sp)

      sp(j, 2) = .Item(sp(j, 3))
    Next
  End With

        With ListBox1
            .Clear
            .ColumnHeads = False
            .ColumnCount = 14
            .ColumnWidths = "1cm;1cm;5cm;5cm;5cm;2cm;0cm;0cm;0cm;0cm;0cm;0cm;0cm;0cm"
            .ListWidth = "26cm"
            .List = sp

        End With

With ActiveWindow
 .WindowState = xlMaximized
End With
'ListBox2.Clear
lbl_DSgefunden = ListBox1.ListCount
Exit Sub
fehler:
MsgBox "Error in: " & ActiveSheet.Name & Chr(10) & "Division: Sub Userform_initialize" & vbCrLf & "Fehlernummer: " & Err.Number & _
    vbCrLf & "Fehlerbeschreibung: " & Err.Description
End Sub


VG
1Matthias
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 716
Registriert: 15. Aug 2017, 18:36

Re: 2 Arrays prüfen und neu zusammenfügen

Beitragvon Vulkanier » 13. Dez 2020, 01:18

Hallo,
vielen Dank für die anpassung von @snb seinem code.
Es funktioniert.
Wie müsste ich den code anpassen um die erste zeile (Lfd.Nr.; ArtName; usw...) nicht mit anzuzeigen?
LG
Man muss viel gelernt haben, um über das, was man nicht weiß, fragen zu können.
(Jean-Jacques Rousseau)
Benutzeravatar
Vulkanier
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 86
Registriert: 31. Mär 2015, 07:06

Re: 2 Arrays prüfen und neu zusammenfügen

Beitragvon 1Matthias » 13. Dez 2020, 10:48

Moin!
Da müsstest du am Anfang das Array sp anders dimensionieren und dann nochmal die Schleife beim Eintragen der Namen. Habe das mal geändert und im Sinne von snb als Einzeiler gelassen.
Code: Alles auswählen
Option Explicit
Private Sub UserForm_Initialize()
'On Error GoTo fehler
Dim rletzte As Long
Dim lngIndex As Long, temp
Dim sn, sp, j
Dim rng As Range
'Fenster ganzer Bildschirm
Me.Top = Application.Top
Me.Left = Application.Left
Me.Height = Application.Height
Me.Width = Application.Width
'******************************************

 sn = Workbooks("Kunden.xls").Sheets(1).Cells(1).CurrentRegion.Resize(, 2)
 Workbooks("artikel.xls").Sheets(1).Columns(2).Insert
  sp = Workbooks("artikel.xls").Sheets(1).Cells(2, 1).Resize(Workbooks("artikel.xls").Sheets(1).Cells(1).CurrentRegion.Rows.Count - 1, 11)

  Workbooks("artikel.xls").Sheets(1).Columns(2).Delete
 
 
  With CreateObject("scripting.dictionary")
    For j = 2 To UBound(sn)
      .Item(sn(j, 1)) = sn(j, 2)
    Next
    For j = 1 To UBound(sp)

      sp(j, 2) = .Item(sp(j, 3))
    Next
  End With

        With ListBox1
            .Clear
            .ColumnHeads = False
            .ColumnCount = 14
            .ColumnWidths = "1cm;1cm;5cm;5cm;5cm;2cm;0cm;0cm;0cm;0cm;0cm;0cm;0cm;0cm"
            .ListWidth = "26cm"
            .List = sp

        End With

With ActiveWindow
 .WindowState = xlMaximized
End With
'ListBox2.Clear
lbl_DSgefunden = ListBox1.ListCount
Exit Sub
fehler:
MsgBox "Error in: " & ActiveSheet.Name & Chr(10) & "Division: Sub Userform_initialize" & vbCrLf & "Fehlernummer: " & Err.Number & _
    vbCrLf & "Fehlerbeschreibung: " & Err.Description
End Sub


VG
1Matthias
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 716
Registriert: 15. Aug 2017, 18:36

Re: 2 Arrays prüfen und neu zusammenfügen

Beitragvon Vulkanier » 13. Dez 2020, 12:30

Mahlzeit,
vielen Dank für deine Hilfe, so läufts es. :P
Ist zu guter letzt auch noch eine Sortierung nach der 2. Spalte möglich :roll:

LG
Man muss viel gelernt haben, um über das, was man nicht weiß, fragen zu können.
(Jean-Jacques Rousseau)
Benutzeravatar
Vulkanier
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 86
Registriert: 31. Mär 2015, 07:06

Re: 2 Arrays prüfen und neu zusammenfügen

Beitragvon snb » 13. Dez 2020, 12:35

Man sollte
- die Artikel Datei als .xlsb speichern
- die Kunden Datie irgendwo speichern
- die Listbox Eigenschaften im Entwurf Modus speichern

Dann reicht:

Code: Alles auswählen
Private Sub UserForm_Initialize()
  sn = Tabelle1.Cells(1).CurrentRegion
  With GetObject("G:\OF\Kunden.xlsx")
    sp = .Sheets(1).Cells(1).CurrentRegion
    st = .Sheets(1).Cells(1).CurrentRegion.Columns(1)
    .Close 0
  End With
   
  For j = 2 To UBound(sn)
    sn(j, 2) = sp(Application.Match(sn(j, 2), st, 0), 2)
  Next
   
  ListBox1.List = sn
End Sub
Du hast keine ausreichende Berechtigung, um die Dateianhänge dieses Beitrags anzusehen.
snb
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 8198
Registriert: 25. Sep 2014, 16:37

Re: 2 Arrays prüfen und neu zusammenfügen

Beitragvon Vulkanier » 13. Dez 2020, 18:54

Hallo,
vielen dank für deine Mühe.
Kann man den code noch anpassen, das die Key-Spalte erhalten bleibt und die Spalte KundenName daneben eingefügt wird.
Weiterhin wäre eine Sortierung nach KundenName sehr schön.

LG
Man muss viel gelernt haben, um über das, was man nicht weiß, fragen zu können.
(Jean-Jacques Rousseau)
Benutzeravatar
Vulkanier
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 86
Registriert: 31. Mär 2015, 07:06

Nächste

Zurück zu Excel Forum (provisorisch)

Wer ist online?

Mitglieder in diesem Forum: 0 Mitglieder und 8 Gäste