VBA challenge: Loop through rows and separate date Span

[KDavidP1987]

Hello all,

I am trying to find a method to loop through rows in a named table, copying each row over to another table and adding a value in a blank field on the end of each row which sequences the dates between a datespan.

I came across code which can separate a datespan successfully into rows, but have been having trouble creating a loop to go through each row of data and copying the rest over.

Example of data from table (w/ headers):

Table Name: TblOGCalendar

[TABLE="width: 600"]
<tbody>[TR]
[TD]Employee[/TD]
[TD]Category[/TD]
[TD]Start Time[/TD]
[TD]End Time[/TD]
[TD]Event Description[/TD]
[TD]Days[/TD]
[TD]All Day Event[/TD]
[/TR]
[TR]
[TD]John Smith[/TD]
[TD]PTO[/TD]
[TD]1/2/2019[/TD]
[TD]1/4/2019[/TD]
[TD]Vacation[/TD]
[TD]3[/TD]
[TD]Yes[/TD]
[/TR]
[TR]
[TD]Jane Smith[/TD]
[TD]PTO[/TD]
[TD]2/5/2019[/TD]
[TD]2/7/2019[/TD]
[TD]Personal[/TD]
[TD]3[/TD]
[TD]Yes[/TD]
[/TR]
</tbody>[/TABLE]

Should be copied over to look like the following:

Table Name: TblR2Calendar

[TABLE="width: 700"]
<tbody>[TR]
[TD]Employee[/TD]
[TD]Category[/TD]
[TD]Start Time[/TD]
[TD]End Time[/TD]
[TD]Event Description[/TD]
[TD]Days[/TD]
[TD]All Day Event[/TD]
[TD]Date[/TD]
[/TR]
[TR]
[TD]John Smith[/TD]
[TD]PTO[/TD]
[TD]1/2/2019[/TD]
[TD]1/4/2019[/TD]
[TD]Vacation[/TD]
[TD]3[/TD]
[TD]Yes[/TD]
[TD]1/2/2019[/TD]
[/TR]
[TR]
[TD]John Smith[/TD]
[TD]PTO[/TD]
[TD]1/2/2019[/TD]
[TD]1/4/2019[/TD]
[TD]Vacation[/TD]
[TD]3[/TD]
[TD]Yes[/TD]
[TD]1/3/2019[/TD]
[/TR]
[TR]
[TD]John Smith[/TD]
[TD]PTO[/TD]
[TD]1/2/2019[/TD]
[TD]1/4/2019[/TD]
[TD]Vacation[/TD]
[TD]3[/TD]
[TD]Yes[/TD]
[TD]1/4/2019[/TD]
[/TR]
[TR]
[TD]Jane Smith[/TD]
[TD]PTO[/TD]
[TD]2/5/2019[/TD]
[TD]2/7/2019[/TD]
[TD]Personal[/TD]
[TD]3[/TD]
[TD]Yes[/TD]
[TD]2/5/2019[/TD]
[/TR]
[TR]
[TD]Jane Smith[/TD]
[TD]PTO[/TD]
[TD]2/5/2019[/TD]
[TD]2/7/2019[/TD]
[TD]Personal[/TD]
[TD]3[/TD]
[TD]Yes[/TD]
[TD]2/6/2019[/TD]
[/TR]
[TR]
[TD]Jane Smith[/TD]
[TD]PTO[/TD]
[TD]2/5/2019[/TD]
[TD]2/7/2019[/TD]
[TD]Personal[/TD]
[TD]3[/TD]
[TD]Yes[/TD]
[TD]2/7/2019[/TD]
[/TR]
</tbody>[/TABLE]


Code to separate date-span:

Sub WriteDates()


    Dim rng As Range
    Dim StartRng As Range
    Dim EndRng As Range
    Dim OutRng As Range
    Dim StartValue As Variant
    Dim EndValue As Variant
    xTitleId = "KutoolsforExcel"
    Set StartRng = Application.Selection
    Set StartRng = Application.InputBox("Start Range (single cell):", xTitleId, StartRng.Address, Type:=8)
    Set EndRng = Application.InputBox("End Range (single cell):", xTitleId, Type:=8)
    Set OutRng = Application.InputBox("Out put to (single cell):", xTitleId, Type:=8)
    Set OutRng = OutRng.Range("A1")
    StartValue = StartRng.Range("A1").Value
    EndValue = EndRng.Range("A1").Value
    If EndValue - StartValue <= 0 Then
        Exit Sub
        End If
        ColIndex = 0
        For i = StartValue To EndValue
            OutRng.Offset(ColIndex, 0) = i
            ColIndex = ColIndex + 1
        Next
    End Sub

Thank you, in advance, for any potential solutions!

Sincerely,
Kris

 

[MoshiM]

Hello all,

I am trying to find a method to loop through rows in a named table, copying each row over to another table and adding a value in a blank field on the end of each row which sequences the dates between a datespan.

I came across code which can separate a datespan successfully into rows, but have been having trouble creating a loop to go through each row of data and copying the rest over.

This is tested for appending the first table's contents to the bottom of the second assuming that both are on the same worksheet and that your macro works on the first table and then you want to move stuff

Sub Help()Dim H() As Variant, TB1 As ListObject, TB2 As ListObject, Add As String, Target_Range As Range, Moo() As String, N(1 To 2) As Long, L(1 To 2) As String, _
New_Range As Range, Data1() As Variant

Call WriteDates
Set TB1 = ActiveSheet.ListObjects("TblOGCalendar")
Set TB2 = ActiveSheet.ListObject("TblR2Calendar")


Add = TB2.DataBodyRange.Address
Data1 = TB1.DataBodyRange.value2


Add = Replace(Add, ":", vbNullString): Add = Replace(Add, Chr(34), vbNullString)
Moo = Split(Add, "$")


N1 = 1: L1 = 1
For X = LBound(Moo) + 1 To UBound(Moo)
    
    If IsNumeric(Moo(X)) Then
        N(N1) = CLng(Moo(X)): N1 = N1 + 1
    Else
        L(L1) = Moo(X): L1 = L1 + 1
    End If
    
Next X


Set New_Range = Range(L(1) & N(2) + 1)
New_Range.Resize(UBound(Data1, 1), UBound(Data1, 2)).Value = Data1



End Sub

 

[MoshiM]

in case you get an error

[COLOR=#333333]Set TB2 = ActiveSheet.ListObject("TblR2Calendar")[/COLOR]

to

[COLOR=#333333]Set TB2 = ActiveSheet.ListObjects("TblR2Calendar")[/COLOR]