VBA script datum uitsplitsen

[moensk]

ik heb een begin en einddatum welke in 1 rij staat
nu zoek ik script dat per dag een rij maakt beginnend bij begindatum gaande tot einddatum
in bijlage een klein voorbeeldje gemaakt

 

[SjonR]

zo?

Sub SjonR()
arr = Cells(1).CurrentRegion

For i = 2 To UBound(arr)
    aantalregels = aantalregels + (arr(i, 3) - arr(i, 2) + 1)
Next

ReDim arr2(aantalregels, 3) 
    For i = 2 To UBound(arr)
        For j = 0 To arr(i, 3) - arr(i, 2)
            arr2(n, 0) = arr(i, 1)
            arr2(n, 1) = arr(i, 2) + j
            arr2(n, 2) = arr(i, 4)
            n = n + 1
        Next
    Next
Cells(2, 6).Resize(aantalregels, 3) = arr2
End Sub

 

[VenA]

of

Sub VenA()
  ar = Sheets("Blad1").Cells(1).CurrentRegion
  ReDim ar1(2, 0)
  For j = 3 To UBound(ar)
    For jj = ar(j, 2) To ar(j, 3)
      ar1(0, UBound(ar1, 2)) = ar(j, 1)
      ar1(1, UBound(ar1, 2)) = Format(jj, "mm-dd-yyyy")
      ar1(2, UBound(ar1, 2)) = ar(j, 4)
      ReDim Preserve ar1(2, UBound(ar1, 2) + 1)
    Next jj
  Next j
  Sheets("Blad1").Cells(1, 10).Resize(UBound(ar1, 2), 3) = Application.Transpose(ar1)
End Sub

 

[HSV]

Of:

Sub hsv()
Dim sv, hs, i As Long, s0 As String, s1 As String
 sv = Cells(1).CurrentRegion
        For i = 3 To UBound(sv)
          s0 = s0 & Replace(String(sv(i, 3) - sv(i, 2) + 1, " "), " ", " " & i)
          s1 = s1 & " =" & Join(Evaluate("transpose(row(1:" & sv(i, 3) - sv(i, 2) + 1 & ")-1)"), "+" & CLng(sv(i, 2)) & " =") & "+" & CLng(sv(i, 2))
        Next
     hs = Application.Transpose(Split(Trim(s0)))
   Cells(1, 10).Resize(UBound(hs), 3) = Application.Index(sv, hs, Array(1, 2, 4))
   Cells(1, 11).Resize(UBound(hs)) = Application.Transpose(Split(Trim(s1)))
End Sub

Of:

Sub hsv()
Dim sv, hs, i As Long, s0 As String, s1 As String
  sv = Cells(1).CurrentRegion
        For i = 3 To UBound(sv)
          s0 = s0 & Replace(String(sv(i, 3) - sv(i, 2) + 1, " "), " ", " " & i)
          s1 = s1 & " =" & Join(Evaluate("transpose(row(1:" & sv(i, 3) - sv(i, 2) + 1 & ")-1)"), "+" & CLng(sv(i, 2)) & " =") & "+" & CLng(sv(i, 2))
        Next
     hs = Application.Transpose(Split(Trim(s0)))
   With Cells(1, 10)
      .Resize(UBound(hs), 3) = Application.Index(sv, hs, Array(1, 2, 4))
      .Offset(, 1).Resize(UBound(hs)) = Application.Transpose(Split(Trim(s1)))
      .CurrentRegion = .CurrentRegion.Value
   End With
End Sub

 

[snb]

Of

Sub M_snb()
  ReDim sp(2000, 2)
  sn = Sheet1.Cells(1).CurrentRegion
    
  y = 3
  For j = 0 To UBound(sp)
    sp(j, 0) = sn(y, 1)
    sp(j, 1) = sn(y, 2) + x
    sp(j, 2) = sn(y, 4)
    x = x + 1

    If sn(y, 2) + x > sn(y, 3) Then
      x=0
      y = y + 1
      If y > UBound(sn) Then Exit For
    End If
  Next
    
  Cells(20, 6).Resize(UBound(sp), 3) = sp
End Sub

 

[rebmog]

Of een VBA-oplossing gebaseerd op formules (zal bij veel data waarschijnlijk niet de snelste oplossing zijn ...):

Sub rebmog()
    Dim i As Long, j As Long
    i = Cells(1).CurrentRegion.Rows.Count
    j = Evaluate("sum(c3:c" & i & "+1-b3:b" & i & ")")
    Range("J3").Resize(j).Formula = "=offset(a$3,iferror(match(j2,a$3:a$" & j & ",0)-(vlookup(j2,a$3:c$" & j & ",3,0)-vlookup(j2,a$3:b$" & j & ",2,0)>=countif(j$2:j2,j2)),0),)"
    Range("K3").Resize(j).Formula = "=(if(j2<>j3,vlookup(j3,a$3:b$" & j & ",2,0),k2+1))"
    Range("K3").Resize(j).NumberFormat = "m/d/yyyy"
    Range("L3").Resize(j).Formula = "=(if(j2<>j3,vlookup(j3,a$3:d$" & j & ",4,0),l2))"
    Range("J3").Resize(j, 3).Value = Range("J3").Resize(j, 3).Value
End Sub

 

[moensk]

Allen bedankt voor de vele reacties,
Veel bruikbare codes gezien en reeds gebruikt

 

[moensk]

kan iemand even kijken waarom script niet werkt
alvast bedankt

 

[VenA]

Dat kan je zelf ook zien. Gebruik de ingebouwde debug methodes.

 

[moensk]

hieronder script om datumnotatie aan te passen
de range staat nu op "c2 : c40" en "d2 : d40" doch deze varieert
hoe kan ik zorgen dat de range zich automatisch aanpast aan de import

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  'datum aanpassen van yyyy-mm-dd naar dd-mm-yyyy
  For Each cl In Range("C2:C40")
    cl.NumberFormat = "mm-dd-yyyy"
    cl.Value = cl.Value
  Next
  For Each cl In Range("D2:D40")
    cl.NumberFormat = "mm-dd-yyyy"
    cl.Value = cl.Value
  Next
End Sub

 

[snb]

Ben je bekend met

Range("C2:D40")

?

 

[moensk]

snb,
kan script zo vereenvoudigen, was nog aan testen in beide kolommen
doch hoe kan ik D40 automatisch laten bepalen afhankelijk van aantal gevulde rijen ?

 

[HSV]

Bv.

with cells(1).currentregion.offset(1,2).resize(,2)
 .numberformat = "mm-dd-yyyy"
 .value = .value
 end with