Registriert seit: 19.04.2018
Version(en): 2010
(21.05.2018, 17:18)Elex schrieb: Kannst ja mal Bescheid geben wie lange der Code etwa braucht.
Der Code benötigt etwa drei Minuten für mehr als 4k Zeilen. Jetzt habe ich folgendes Problem, und zwar habe ich die Spalten so angepasst, wie in deinem Beispiel, jedoch scheint alles verschoben zu sein.
Kannst du mir bitte bei Gelegenheit ein paar Kommentare in den Code schreiben, damit ich die Bezüge besser verstehe.
Registriert seit: 16.08.2017
Version(en): 2007 / 2010 / Web
Hi
Zitat:Jetzt habe ich folgendes Problem, und zwar habe ich die Spalten so angepasst, wie in deinem Beispiel, jedoch scheint alles verschoben zu sein.
Wieso in meinem Beispiel? Deine Beispieldatei habe ich im Bezug auf Spalten doch nicht geändert.
Zitat:Der Code benötigt etwa drei Minuten für mehr als 4k Zeilen.
Klingt nicht so schnell. Versuche es noch mal mit dem Code. Eine Vorsortierung der Tabelle2 ist nicht mehr nötig.
Code: Public Sub Liste()
Dim objDict As Object
Dim ArrTab1, ArrTab2 As Variant
Dim LetzA, n, z As Long
LetzA = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Range("C2:J" & LetzA).ClearContents
ArrTab1 = Range("A1:J" & LetzA).Value
ArrTab2 = Sheets("Sheet2").Range("A1").CurrentRegion
Set objDict = CreateObject("Scripting.Dictionary")
For n = 2 To UBound(ArrTab1, 1)
If objDict.exists(ArrTab1(n, 1)) Then
MsgBox "Code abgebrochen! Doppelte in Tab1 " & ArrTab1(n, 1)
Exit Sub
Else
objDict(ArrTab1(n, 1)) = n
End If
Next n
For n = 2 To UBound(ArrTab2, 1)
If objDict.exists(ArrTab2(n, 1)) Then
z = objDict(ArrTab2(n, 1)) 'Die Zeile in Tab1 mit Wert von Tab2(Spalte A)
'Aktuell
If ArrTab1(z, 4) < ArrTab2(n, 4) Then 'Datum vergleich
ArrTab1(z, 4) = ArrTab2(n, 4)
ArrTab1(z, 3) = ArrTab2(n, 5)
End If
'Max
If ArrTab1(z, 5) = ArrTab2(n, 3) Then 'Qty vergleich
If ArrTab1(z, 7) < ArrTab2(n, 4) Then 'Datum vergleich
ArrTab1(z, 6) = ArrTab2(n, 5)
ArrTab1(z, 7) = ArrTab2(n, 4)
End If
Else
If ArrTab1(z, 5) < ArrTab2(n, 3) Then 'Qty vergleich
ArrTab1(z, 5) = ArrTab2(n, 3)
ArrTab1(z, 6) = ArrTab2(n, 5)
ArrTab1(z, 7) = ArrTab2(n, 4)
End If
End If
'Min
If ArrTab1(z, 8) = ArrTab2(n, 3) Then 'Qty vergleich
If ArrTab1(z, 10) < ArrTab2(n, 4) Then 'Datum vergleich
ArrTab1(z, 9) = ArrTab2(n, 5)
ArrTab1(z, 10) = ArrTab2(n, 4)
End If
Else
If ArrTab1(z, 8) > ArrTab2(n, 3) Or ArrTab1(z, 8) = "" Then 'Qty vergleich
ArrTab1(z, 8) = ArrTab2(n, 3)
ArrTab1(z, 9) = ArrTab2(n, 5)
ArrTab1(z, 10) = ArrTab2(n, 4)
End If
End If
End If
Next n
Sheets("Sheet1").Range("A1").Resize(LetzA, 10) = ArrTab1
Set objDict = Nothing
End Sub
Gruß Elex
Folgende(r) 1 Nutzer sagt Danke an Elex für diesen Beitrag:1 Nutzer sagt Danke an Elex für diesen Beitrag 28
• Bamane
Registriert seit: 19.04.2018
Version(en): 2010
22.05.2018, 16:54
(Dieser Beitrag wurde zuletzt bearbeitet: 22.05.2018, 16:54 von Bamane.)
Hi Elex,
vielen Dank nochmal. Habe einen kleinen Fehler bei mir entdeckt sorry für die vorige Frage. Jetzt klappt es nur hört der Code nur wird in allen Zellen nur das Datum eingetragen.
Beste Grüsse
Bamane
Registriert seit: 19.04.2018
Version(en): 2010
Hi Elex,
ich bekomme eine Fehlermeldung "Subscript out of Range" und die Zeile mit dem folgenden Code wird geld markiert:
Code: For n = 2 To UBound(ArrTab2, 5)
Ich habe danach die Spaltenangabe wie folgt verändert:
Code: For n = 2 To UBound(ArrTab2, 1)
Dann bekomme ich folgendes Problem: In Tabelle 1 werden bis zur Zeile 1581 in den Spalten 3 bis 10 nur das Datum angezeigt, die aber aus irgendeinem Grund nicht aus meinen Daten entnommen werden. Meistens taucht dieses Datum auf "1/0/1900".
Ab Zeile 1582 werden dann die "richtigen" Daten bis auf in Spalte 8, wo wieder "1/0/1900" mehrmals auftaucht, eingetragen.
In Tabelle 1 sind die Spalten dieselben wie in dem Beispiel. In Tabelle 2 jedoch befinden sich die Angaben in den folgenden Spalten:
- Spalte 5: Component
- Spalte 6: Component description
- Spalte 9: Deliv. Date
- Spalte 11: Qty.
- Spalte 13: Net Price
Deinen Code habe ich folgendermaßen angepasst:
Code: Public Sub Liste()
Dim objDict As Object
Dim ArrTab1, ArrTab2 As Variant
Dim LetzA, n, z As Long
'Worksheets("Build Master").Select
LetzA = Sheets("Build Master").Cells(Rows.Count, 1).End(xlUp).Row
Range("C2:J" & LetzA).ClearContents
ArrTab1 = Range("A1:J" & LetzA).Value
ArrTab2 = Sheets("Prices & Deliv. date").Range("A1").CurrentRegion
Set objDict = CreateObject("Scripting.Dictionary")
For n = 2 To UBound(ArrTab1, 1)
If objDict.exists(ArrTab1(n, 1)) Then
MsgBox "Code abgebrochen! Doppelte in Tab1 " & ArrTab1(n, 1)
Exit Sub
Else
objDict(ArrTab1(n, 1)) = n
End If
Next n
For n = 2 To UBound(ArrTab2, 1)
If objDict.exists(ArrTab2(n, 5)) Then
z = objDict(ArrTab2(n, 5)) 'Die Zeile in Tab1 mit Wert von Tab2(Spalte E)
'Aktuell
If ArrTab1(z, 4) < ArrTab2(n, 9) Then 'Datum vergleich
ArrTab1(z, 4) = ArrTab2(n, 9)
ArrTab1(z, 3) = ArrTab2(n, 13) 'Preis vergleich
End If
'Max
If ArrTab1(z, 5) = ArrTab2(n, 11) Then 'Qty vergleich
If ArrTab1(z, 7) < ArrTab2(n, 9) Then 'Datum vergleich
ArrTab1(z, 6) = ArrTab2(n, 13)
ArrTab1(z, 7) = ArrTab2(n, 9)
End If
Else
If ArrTab1(z, 5) < ArrTab2(n, 11) Then 'Qty vergleich
ArrTab1(z, 5) = ArrTab2(n, 11)
ArrTab1(z, 6) = ArrTab2(n, 13)
ArrTab1(z, 7) = ArrTab2(n, 9)
End If
End If
'Min
If ArrTab1(z, 8) = ArrTab2(n, 11) Then 'Qty vergleich
If ArrTab1(z, 10) < ArrTab2(n, 9) Then 'Datum vergleich
ArrTab1(z, 9) = ArrTab2(n, 13)
ArrTab1(z, 10) = ArrTab2(n, 9)
End If
Else
If ArrTab1(z, 8) > ArrTab2(n, 11) Or ArrTab1(z, 8) = "" Then 'Qty vergleich
ArrTab1(z, 8) = ArrTab2(n, 11)
ArrTab1(z, 9) = ArrTab2(n, 13)
ArrTab1(z, 10) = ArrTab2(n, 9)
End If
End If
End If
Next n
Sheets("Build Master").Range("A1").Resize(LetzA, 10) = ArrTab1
Set objDict = Nothing
End Sub
Gruss
Bamane
Registriert seit: 16.08.2017
Version(en): 2007 / 2010 / Web
Hi
Versuche es so.
Code: Public Sub Liste()
Dim objDict As Object
Dim ArrTab1, ArrTab2 As Variant
Dim LetzA, n, z As Long
LetzA = Sheets("Build Master").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Build Master").Range("C2:J" & LetzA).ClearContents
ArrTab1 = Sheets("Build Master").Range("A1:J" & LetzA).Value
ArrTab2 = Sheets("Prices & Deliv. date").Range("E1:M" & Sheets("Prices & Deliv. date").Cells(Rows.Count, 5).End(xlUp).Row)
Set objDict = CreateObject("Scripting.Dictionary")
For n = 2 To UBound(ArrTab1, 1)
If objDict.exists(ArrTab1(n, 1)) Then
MsgBox "Code abgebrochen! Doppelte in Tab1 " & ArrTab1(n, 1)
Exit Sub
Else
objDict(ArrTab1(n, 1)) = n
End If
Next n
For n = 2 To UBound(ArrTab2, 1)
If objDict.exists(ArrTab2(n, 1)) Then
z = objDict(ArrTab2(n, 1)) 'Die Zeile in Tab1 mit Wert von Tab2(Spalte E)
'Aktuell
If ArrTab1(z, 4) < ArrTab2(n, 5) Then 'Datum vergleich
ArrTab1(z, 4) = ArrTab2(n, 5)
ArrTab1(z, 3) = ArrTab2(n, 9)
End If
'Max
If ArrTab1(z, 5) = ArrTab2(n, 7) Then 'Qty vergleich
If ArrTab1(z, 7) < ArrTab2(n, 5) Then 'Datum vergleich
ArrTab1(z, 6) = ArrTab2(n, 9)
ArrTab1(z, 7) = ArrTab2(n, 5)
End If
Else
If ArrTab1(z, 5) < ArrTab2(n, 7) Then 'Qty vergleich
ArrTab1(z, 5) = ArrTab2(n, 7)
ArrTab1(z, 6) = ArrTab2(n, 9)
ArrTab1(z, 7) = ArrTab2(n, 5)
End If
End If
'Min
If ArrTab1(z, 8) = ArrTab2(n, 7) Then 'Qty vergleich
If ArrTab1(z, 10) < ArrTab2(n, 5) Then 'Datum vergleich
ArrTab1(z, 9) = ArrTab2(n, 9)
ArrTab1(z, 10) = ArrTab2(n, 5)
End If
Else
If ArrTab1(z, 8) > ArrTab2(n, 7) Or ArrTab1(z, 8) = "" Then 'Qty vergleich
ArrTab1(z, 8) = ArrTab2(n, 7)
ArrTab1(z, 9) = ArrTab2(n, 9)
ArrTab1(z, 10) = ArrTab2(n, 5)
End If
End If
End If
Next n
Sheets("Build Master").Range("A1").Resize(LetzA, 10) = ArrTab1
Set objDict = Nothing
End Sub
Folgende(r) 1 Nutzer sagt Danke an Elex für diesen Beitrag:1 Nutzer sagt Danke an Elex für diesen Beitrag 28
• Bamane
Registriert seit: 19.04.2018
Version(en): 2010
Hi Elex, da passiert dasselbe.
Registriert seit: 16.08.2017
Version(en): 2007 / 2010 / Web
Zum Vergleichen.
Liste 2.xlsm (Größe: 21,42 KB / Downloads: 3)
Folgende(r) 1 Nutzer sagt Danke an Elex für diesen Beitrag:1 Nutzer sagt Danke an Elex für diesen Beitrag 28
• Bamane
Registriert seit: 19.04.2018
Version(en): 2010
Hi Elex, der Code funktioniert hier auch nur teilweise :/
Es existiert weiterhin dieselbe Problematik wie vorher beschrieben.
Registriert seit: 16.08.2017
Version(en): 2007 / 2010 / Web
Hi
Wenn du in meiner letzten Bsp. Datei auf ausführen klickst, kommt bei mir folgendes Ergebnis nach dem Klick.
____|____A____|__________B__________|____C____|_____D_____|___E___|_______F_______|________G________|___H___|_______I_______|________J________|
1|Component|Component Description|Net price|Deliv. Date|Qty Max|Net price (MAX)|Deliv. Date (MAX)|Qty Min|Net price (MIN)|Deliv. Date (MIN)|
2|Komp9 |Name 1 | 222| 06.10.2016| 245| 555| 31.10.2015| 50| 222| 06.10.2016|
3|Komp2 |Name 1 | 444| 25.02.2017| 210| 222| 24.06.2016| 15| 333| 31.10.2016|
4|Komp1 |Name 2 | 333| 28.10.2016| 205| 555| 13.08.2016| 10| 222| 08.06.2016|
5|Komp4 |Name 2 | 555| 25.01.2017| 220| 444| 12.07.2015| 25| 555| 25.01.2017|
6|Komp8 |Name 3 | 333| 16.07.2016| 240| 444| 14.07.2016| 45| 555| 25.10.2015|
7|Komp6 |Name 3 | 222| 07.05.2017| 230| 222| 07.05.2017| 35| 333| 11.07.2015|
8|Komp7 |Name 1 | 333| 18.06.2016| 235| 333| 18.06.2016| 40| 444| 05.05.2016|
9|Komp3 |Name 1 | 222| 08.04.2017| 215| 333| 21.11.2016| 20| 444| 12.11.2016|
10|Komp10 |Name 2 | 222| 17.03.2017| 250| 222| 17.03.2017| 55| 333| 19.09.2016|
11|Komp5 |Name 2 | 555| 12.08.2016| 225| 555| 12.08.2016| 30| 222| 09.06.2016|
Da wirst du wohl noch mal eine Beispiel Datei (gekürzte) erstellen müssen und mir zur Verfügung stellen.
Spalten, Zeilen und Formate wie in der Original Datei. Extra Liste mit Wunschergebnis.
Gibt es leer Zeilen zwischen den Daten?
Wird schon werden.
Wenn nicht dann evtl. dein Vorschlag aus der PN.
Registriert seit: 19.04.2018
Version(en): 2010
Hi, ich habe es genau so ausgeführt außerdem habe ich meine Daten in die jeweiligen Tabellen in deinem Workbook hinzugefügt jedoch passiert hier das gleiche.
Wäre super, wenn du dir meine Datei mit den entsprechenden Daten ansehen könntest. Das Problem ist, dass es ja teilweise funktioniert und nur bei den ersten 1581 Daten nicht wirklich funktioniert.
|