VBA challenge: Loop through rows and separate date Span

KDavidP1987

Board Regular
Joined
Mar 6, 2018
Messages
51
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

EmployeeCategoryStart TimeEnd TimeEvent DescriptionDaysAll Day Event
John SmithPTO1/2/20191/4/2019Vacation3Yes
Jane SmithPTO2/5/20192/7/2019Personal3Yes

<tbody>
</tbody>

Should be copied over to look like the following:

Table Name: TblR2Calendar

EmployeeCategoryStart TimeEnd TimeEvent DescriptionDaysAll Day EventDate
John SmithPTO1/2/20191/4/2019Vacation3Yes1/2/2019
John SmithPTO1/2/20191/4/2019Vacation3Yes1/3/2019
John SmithPTO1/2/20191/4/2019Vacation3Yes1/4/2019
Jane SmithPTO2/5/20192/7/2019Personal3Yes2/5/2019
Jane SmithPTO2/5/20192/7/2019Personal3Yes2/6/2019
Jane SmithPTO2/5/20192/7/2019Personal3Yes2/7/2019

<tbody>
</tbody>


Code to separate date-span:

Code:
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
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.

MoshiM

Active Member
Joined
Jan 31, 2018
Messages
371
Office Version
  1. 2016
Platform
  1. Windows
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
Code:
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
 
Last edited:

MoshiM

Active Member
Joined
Jan 31, 2018
Messages
371
Office Version
  1. 2016
Platform
  1. Windows
in case you get an error
Code:
[COLOR=#333333]Set TB2 = ActiveSheet.ListObject("TblR2Calendar")[/COLOR]
to
Code:
[COLOR=#333333]Set TB2 = ActiveSheet.ListObjects("TblR2Calendar")[/COLOR]
 

Watch MrExcel Video

Forum statistics

Threads
1,130,403
Messages
5,641,936
Members
417,247
Latest member
Chitaah

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top