Tabelleninhalt erweitern via VBA

Hallo Zusammen,
vorab - ich habe leider keine Möglichkeit eine Beispieldatei hochzuladen...von daher versuche ich mein Problem möglichst genau zu schildern.
Meine Tabelle umfasst Spalte A bis J.
In Spalte A ist ein Datum in einer vorher definierten Range (z.B. vom 28.02.2023 bis 30.03.2023).
In Spalte B ist eine Produktnummer (z.B. 000132_002). Diese Produktnummer ist zu jedem Datum genau einmal vorhanden...
In den Spalten C bis J sind Stammdaten zu der Produktnummer gelistet.
In der Tabelle können mehrere Produktnummern enthalten sein - jede Produktnummer dann wie schon gesagt ist zu jedem Datum einmal vorhanden.

Jetzt meine Frage...kann man die definierte Datumsrange bei jedem Produkt um 5 Tage erweitern...in diesem Fall dann bis zum 04.04.2023 und in diese Erweiterung
je die letzten Stammdaten zu dem Produkt (hier also die die beim 30.03.2023 stehen) kopieren, sodass am Ende zu jedem Produkt hier zu den Dati 30.03.2023 bis 04.04.2023 die gleichen Daten in Spalte C bis J stehen?

Ich hoffe ich konnte mein Problem/Herausforderung einigermaßen formulieren und Ihr könnt mir ggf. bei der Lösung helfen.
Vielen Dank vorab.
Viele Grüße Addi

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Unit() Dim lastDate As Date, a As Long, Z As Long, ZZ As Long lastDate = WorksheetFunction.Max(Columns("A")) Z = WorksheetFunction.Match(CLng(lastDate), Columns("A"), 0) ZZ = WorksheetFunction.Match(CLng(lastDate), Columns("A"), 1) For a = CLng(lastDate) + 1 To CLng(lastDate) + 5 Range(Cells(Z, 2), Cells(ZZ, 10)).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1, 1) Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(ZZ - Z + 1, 1) = CDate(a) Next End Sub

Hallo,

Sub Erweitern()
  Dim vntTmp
  Dim i As Long, j As Long, n As Long
  Dim objArt As Object, objLast As Object, oObj
  Dim d As Date
  Dim arrLast, arrOUT()
  
  Dim iAnzTage As Integer
  
  iAnzTage = Application.InputBox("Anzahl Tage?", , , , , , , 1)
  If iAnzTage = 0 Then Exit Sub
  
  Set objArt = CreateObject("scripting.dictionary")
  Set objLast = CreateObject("scripting.dictionary")
  
  vntTmp = Cells(1, 1).CurrentRegion
  
  'Artikel & letztes Datum sammeln
  For i = 2 To UBound(vntTmp)
    objArt(vntTmp(i, 2)) = Application.Max(vntTmp(i, 1), objArt(vntTmp(i, 2)))
  Next
  
  'letzte Werte
  For i = 2 To UBound(vntTmp)
    If CLng(vntTmp(i, 1)) = objArt(vntTmp(i, 2)) Then
      objLast(vntTmp(i, 2)) = Application.Index(vntTmp, i)
    End If
  Next i
  
  arrLast = objLast.items
  ReDim arrOUT(1 To objArt.Count * 5, 1 To UBound(vntTmp, 2))
  
  For i = 0 To UBound(arrLast)
    For d = objArt(arrLast(i)(2)) + 1 To objArt(arrLast(i)(2)) + iAnzTage
      n = n + 1
      arrOUT(n, 1) = d
      For j = 2 To UBound(arrLast(i))
        arrOUT(n, j) = arrLast(i)(j)
      Next j
    Next d
  Next i
  
  Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arrOUT), UBound(arrOUT, 2)) = arrOUT
  
End Sub

Gruß
Rudi

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

41 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Tabelleninhalt erweitern via VBA

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

41 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread