Kopieren in Bezug zum aktuellsten Datum in einem Bereich

[Bamane]

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.

[Elex]

Hi

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.

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

[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

[Bamane]

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

[Elex]

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

[Bamane]

Hi Elex, da passiert dasselbe.

[Elex]

Zum Vergleichen.

  Liste 2.xlsm (Größe: 21,42 KB / Downloads: 3)

[Bamane]

Hi Elex, der Code funktioniert hier auch nur teilweise :/
Es existiert weiterhin dieselbe Problematik wie vorher beschrieben.

[Elex]

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.

[Bamane]

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.