VBA to distribute data monthwise based on start and end date range

M

motherindia

Board Regular
Joined
Oct 15, 2015
Messages
218
Dear Sir,

I have 2 sheets . Sheet1 contains 5 columns of data as below;

[TABLE="width: 426"]
<tbody>[TR]
[TD]Unique No[/TD]
[TD]S Date[/TD]
[TD]E Date[/TD]
[TD]Amt[/TD]
[TD]Type[/TD]
[/TR]
[TR]
[TD="align: right"]1[/TD]
[TD="align: right"]01-Apr-17[/TD]
[TD="align: right"]30-Jun-17[/TD]
[TD="align: right"]100[/TD]
[TD]A[/TD]
[/TR]
[TR]
[TD="align: right"]1[/TD]
[TD="align: right"]01-Jul-17[/TD]
[TD="align: right"]31-Mar-18[/TD]
[TD="align: right"]150[/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD="align: right"]2[/TD]
[TD="align: right"]01-Apr-17[/TD]
[TD="align: right"]30-Apr-17[/TD]
[TD="align: right"]100[/TD]
[TD]A[/TD]
[/TR]
[TR]
[TD="align: right"]2[/TD]
[TD="align: right"]01-May-17[/TD]
[TD="align: right"]31-May-17[/TD]
[TD="align: right"]200[/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD="align: right"]2[/TD]
[TD="align: right"]01-Jun-17[/TD]
[TD="align: right"]30-Jun-17[/TD]
[TD="align: right"]300[/TD]
[TD]A[/TD]
[/TR]
[TR]
[TD="align: right"]2[/TD]
[TD="align: right"]01-Jul-17[/TD]
[TD="align: right"]31-Jul-17[/TD]
[TD="align: right"]400[/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD="align: right"]2[/TD]
[TD="align: right"]01-Aug-17[/TD]
[TD="align: right"]31-Aug-17[/TD]
[TD="align: right"]500[/TD]
[TD]B[/TD]
[/TR]
</tbody><colgroup><col><col span="2"><col><col></colgroup>[/TABLE]


I need to update the info Sheet 2 against the unique id as below;

[TABLE="width: 1600"]


<colgroup><col width="64" style="width: 48pt;" span="25">
<tbody>[TR]

[TD="class: xl65, width: 64, bgcolor: transparent"] [/TD]

[TD="class: xl66, width: 768, bgcolor: transparent, colspan: 12"]Amt[/TD]

[TD="class: xl66, width: 768, bgcolor: transparent, colspan: 12"]Type[/TD]

[/TR]

[TR]

[TD="class: xl65, bgcolor: transparent"]Unique No[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Apr-17[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]May-17[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Jun-17[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Jul-17[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Aug-17[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Sep-17[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Oct-17[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Nov-17[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Dec-17[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Jan-18[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Feb-18[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Mar-18[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Apr-17[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]May-17[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Jun-17[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Jul-17[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Aug-17[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Sep-17[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Oct-17[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Nov-17[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Dec-17[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Jan-18[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Feb-18[/TD]

[TD="class: xl67, bgcolor: transparent, align: right"]Mar-18[/TD]

[/TR]

[TR]

[TD="class: xl65, bgcolor: transparent, align: right"]1[/TD]

[TD="class: xl65, bgcolor: transparent, align: right"]100[/TD]

[TD="class: xl65, bgcolor: transparent, align: right"]100[/TD]

[TD="class: xl65, bgcolor: transparent, align: right"]100[/TD]

[TD="class: xl65, bgcolor: transparent, align: right"]150[/TD]

[TD="class: xl65, bgcolor: transparent, align: right"]150[/TD]

[TD="class: xl65, bgcolor: transparent, align: right"]150[/TD]

[TD="class: xl65, bgcolor: transparent, align: right"]150[/TD]

[TD="class: xl65, bgcolor: transparent, align: right"]150[/TD]

[TD="class: xl65, bgcolor: transparent, align: right"]150[/TD]

[TD="class: xl65, bgcolor: transparent, align: right"]150[/TD]

[TD="class: xl65, bgcolor: transparent, align: right"]150[/TD]

[TD="class: xl65, bgcolor: transparent, align: right"]150[/TD]

[TD="class: xl65, bgcolor: transparent"]A[/TD]

[TD="class: xl65, bgcolor: transparent"]A[/TD]

[TD="class: xl65, bgcolor: transparent"]A[/TD]

[TD="class: xl65, bgcolor: transparent"]B[/TD]

[TD="class: xl65, bgcolor: transparent"]B[/TD]

[TD="class: xl65, bgcolor: transparent"]B[/TD]

[TD="class: xl65, bgcolor: transparent"]B[/TD]

[TD="class: xl65, bgcolor: transparent"]B[/TD]

[TD="class: xl65, bgcolor: transparent"]B[/TD]

[TD="class: xl65, bgcolor: transparent"]B[/TD]

[TD="class: xl65, bgcolor: transparent"]B[/TD]

[TD="class: xl65, bgcolor: transparent"]B[/TD]

[/TR]

[TR]

[TD="class: xl65, bgcolor: transparent, align: right"]2[/TD]

[TD="class: xl65, bgcolor: transparent, align: right"]100[/TD]

[TD="class: xl65, bgcolor: transparent, align: right"]200[/TD]

[TD="class: xl65, bgcolor: transparent, align: right"]300[/TD]

[TD="class: xl65, bgcolor: transparent, align: right"]400[/TD]

[TD="class: xl65, bgcolor: transparent, align: right"]500[/TD]

[TD="class: xl65, bgcolor: transparent"] [/TD]

[TD="class: xl65, bgcolor: transparent"] [/TD]

[TD="class: xl65, bgcolor: transparent"] [/TD]

[TD="class: xl65, bgcolor: transparent"] [/TD]

[TD="class: xl65, bgcolor: transparent"] [/TD]

[TD="class: xl65, bgcolor: transparent"] [/TD]

[TD="class: xl65, bgcolor: transparent"] [/TD]

[TD="class: xl65, bgcolor: transparent"]A[/TD]

[TD="class: xl65, bgcolor: transparent"]B[/TD]

[TD="class: xl65, bgcolor: transparent"]A[/TD]

[TD="class: xl65, bgcolor: transparent"]B[/TD]

[TD="class: xl65, bgcolor: transparent"]B[/TD]

[TD="class: xl65, bgcolor: transparent"] [/TD]

[TD="class: xl65, bgcolor: transparent"] [/TD]

[TD="class: xl65, bgcolor: transparent"] [/TD]

[TD="class: xl65, bgcolor: transparent"] [/TD]

[TD="class: xl65, bgcolor: transparent"] [/TD]

[TD="class: xl65, bgcolor: transparent"] [/TD]

[TD="class: xl65, bgcolor: transparent"] [/TD]

[/TR]




Kindly do the needful.

regards,
motherindia</tbody>[/TABLE]
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Sort by date Sort by votes

Book1
ABCDE
1Unique NoS DateE DateAmtType
2101-Apr-1730-Jun-17100A
3101-Jul-1731-Mar-18150B
4201-Apr-1730-Apr-17100A
5201-May-1731-May-17200B
6201-Jun-1730-Jun-17300A
7201-Jul-1731-Jul-17400B
8201-Aug-1731-Aug-17500B
Sheet1



Book1
ABCDEFGHIJKLMNOPQRSTUVWXY
1AmtType
2Unique NoApr-17May-17Jun-17Jul-17Aug-17Sep-17Oct-17Nov-17Dec-17Jan-18Feb-18Mar-18Apr-17May-17Jun-17Jul-17Aug-17Sep-17Oct-17Nov-17Dec-17Jan-18Feb-18Mar-18
31
42
Sheet2


Code: 
Option Explicit
Public Sub DistributeMonthwise()

Dim lastRow1 As Long
Dim lastRow2 As Long
Dim thisRow1 As Long
Dim thisRow2 As Long
Dim thisCol2 As Long
Dim wsSheet1 As Worksheet
Dim wsSheet2 As Worksheet
Dim startDate As Date
Dim endDate As Date
Dim monthlyAmount As Long
Dim monthlyType As String

' Set up the sheets
Set wsSheet1 = Worksheets("Sheet1") ' Change name as appropriate
Set wsSheet2 = Worksheets("Sheet2") ' Change name as appropriate

' Find the last rows and columns
lastRow1 = wsSheet1.Cells(wsSheet1.Rows.Count, 1).End(xlUp).Row
lastRow2 = wsSheet2.Cells(wsSheet2.Rows.Count, 1).End(xlUp).Row

' Process all rows
For thisRow1 = 2 To lastRow1
    For thisRow2 = 3 To lastRow2
        For thisCol2 = 2 To 13
            If wsSheet2.Cells(2, thisCol2).Value >= wsSheet1.Cells(thisRow1, 2).Value _
            And wsSheet2.Cells(2, thisCol2).Value <= wsSheet1.Cells(thisRow1, 3).Value _
            And wsSheet2.Cells(thisRow2, 1).Value = wsSheet1.Cells(thisRow1, 1).Value Then
                wsSheet2.Cells(thisRow2, thisCol2).Value = wsSheet1.Cells(thisRow1, 4).Value
                wsSheet2.Cells(thisRow2, thisCol2 + 12).Value = wsSheet1.Cells(thisRow1, 5).Value
            End If
        Next thisCol2
    Next thisRow2
Next thisRow1

End Sub

WBD
 
Upvote 0
Dear Sir,

Thank you so much for quick responses. When I tried it on 50k rows it is taking a lot of time. In 1 min it could complete 10 rows only and still running. Is there a way to speed up the procedure.

Regards,
motherindia
 
Upvote 0
Hey,

I didn't code for speed in the first instance. This might work a little quicker:

Code: 
Option Explicit
Public Sub DistributeMonthwise()

Dim lastRow1 As Long
Dim lastRow2 As Long
Dim thisRow1 As Long
Dim thisRow2 As Variant
Dim thisCol2 As Variant
Dim wsSheet1 As Worksheet
Dim wsSheet2 As Worksheet
Dim startDate As Date
Dim endDate As Date
Dim monthlyAmount As Long
Dim monthlyType As String

' Turn off screen updating
Application.ScreenUpdating = False

' Set up the sheets
Set wsSheet1 = Worksheets("Sheet1") ' Change name as appropriate
Set wsSheet2 = Worksheets("Sheet2") ' Change name as appropriate

' Find the last rows and columns
lastRow1 = wsSheet1.Cells(wsSheet1.Rows.Count, 1).End(xlUp).Row
lastRow2 = wsSheet2.Cells(wsSheet2.Rows.Count, 1).End(xlUp).Row

' Process all rows
For thisRow1 = 2 To lastRow1
    ' Find the row on Sheet2 for this unique ID
    thisRow2 = Application.Match(wsSheet1.Cells(thisRow1, 1).Value, wsSheet2.Range("A3:A" & lastRow2), 0)
    
    ' Check we found it
    If Not IsError(thisRow2) Then
        ' Retrieve other data
        startDate = wsSheet1.Cells(thisRow1, 2).Value
        endDate = wsSheet1.Cells(thisRow1, 3).Value
        monthlyAmount = wsSheet1.Cells(thisRow1, 4).Value
        monthlyType = wsSheet1.Cells(thisRow1, 5).Value
        
        ' Process each month
        Do While startDate <= endDate
            ' Find the right column
            thisCol2 = Application.Match(CLng(startDate), wsSheet2.Range("B2:M2"), 0)
            
            ' Check we found one
            If Not IsError(thisCol2) Then
                ' Put in the monthly amount and type
                wsSheet2.Cells(thisRow2 + 2, thisCol2 + 1).Value = monthlyAmount
                wsSheet2.Cells(thisRow2 + 2, thisCol2 + 13).Value = monthlyType
            End If
            
            ' Next month
            startDate = DateSerial(Year(startDate), Month(startDate) + 1, 1)
        Loop
    End If
    
    ' Allow a breakpoint ;-)
    DoEvents
Next thisRow1

' Turn on screen updating
Application.ScreenUpdating = True

End Sub

WBD
 
Upvote 0
Hello Sir,
Thank you so much once again. However, as you said it is quite faster, but took almost 30 min for 20k rows now.

is it possible to use array or redim statement so that it can speed up . I don't know how to use redim statement etc.


Regards,
motherindia
 
Upvote 0
Hello Sir,

Can anyone help me in modifying the above code to increase the speed. When i tested on 60k rows it took around 1 hr.

Thanks once again.

Regards,
motherindia.
 
Upvote 0
Maybe you just have to accept that you have a lot of data to trawl through. Last possibility on the same theme:

Code: 
Option Explicit
Public Sub DistributeMonthwise()

Dim lastRow1 As Long
Dim lastRow2 As Long
Dim thisRow1 As Long
Dim thisRow2 As Variant
Dim thisCol2 As Long
Dim wsSheet1 As Worksheet
Dim wsSheet2 As Worksheet
Dim startDate As Date
Dim endDate As Date
Dim monthlyAmount As Long
Dim monthlyType As String

' Turn off screen updating
Application.ScreenUpdating = False

' Set up the sheets
Set wsSheet1 = Worksheets("Sheet1") ' Change name as appropriate
Set wsSheet2 = Worksheets("Sheet2") ' Change name as appropriate

' Find the last rows and columns
lastRow1 = wsSheet1.Cells(wsSheet1.Rows.Count, 1).End(xlUp).Row
lastRow2 = wsSheet2.Cells(wsSheet2.Rows.Count, 1).End(xlUp).Row

' Process all rows
For thisRow1 = 2 To lastRow1
    ' Find the row on Sheet2 for this unique ID
    thisRow2 = Application.Match(wsSheet1.Cells(thisRow1, 1).Value, wsSheet2.Range("A3:A" & lastRow2), 0)
    
    ' Check we found it
    If Not IsError(thisRow2) Then
        ' Retrieve other data
        startDate = wsSheet1.Cells(thisRow1, 2).Value
        endDate = wsSheet1.Cells(thisRow1, 3).Value
        monthlyAmount = wsSheet1.Cells(thisRow1, 4).Value
        monthlyType = wsSheet1.Cells(thisRow1, 5).Value
        
        ' Process each month
        For thisCol2 = 2 To 13
            If wsSheet2.Cells(2, thisCol2).Value >= startDate _
            And wsSheet2.Cells(2, thisCol2).Value <= endDate Then
                ' Put in the monthly amount and type
                wsSheet2.Cells(thisRow2 + 2, thisCol2).Value = monthlyAmount
                wsSheet2.Cells(thisRow2 + 2, thisCol2 + 12).Value = monthlyType
            End If
        Next thisCol2
    End If
    
    ' Allow a breakpoint ;-)
    DoEvents
Next thisRow1

' Turn on screen updating
Application.ScreenUpdating = True

End Sub

Failing that, you might need to consider alternative solutions.

WBD
 
Upvote 0
Thank you so much for your efforts and time.
However, code runs and does not comes out of loop and when i debug it stuck at row 3.

Anyway i will mange with your previous code for each 10k rows.

Regards,
motherindia
 
Upvote 0
To improve speed you maybe able to utilize my function.
Does it help?

Code: 
Sub Test()

'Start of Code
 '~~> Speeding Up VBA Code
    Call SpeedUp(False)


'End of code
 '~~> Speeding Up VBA Code
    Call SpeedUp(False)


End Sub



Public Function SpeedUp(Optional bSpeed As Boolean = True)
With Application
    .ScreenUpdating = bSpeed 'Prevent screen flickering
    .Calculation = IIf(bSpeed, xlAutomatic, xlCalculationManual) 'Preventing calculation
    .DisplayAlerts = bSpeed 'Turn OFF alerts
    .EnableEvents = bSpeed 'Prevent All Events
    '.Cursor = IIf(bSpeed, xlDefault, xlWait) 'Prevent Hour Glass
    .StatusBar = IIf(bSpeed, vbNullString, "Please wait...")
End With
End Function
 
Upvote 0
Hello Biz Sir,

Thank you so much sharing the code for speeding up macro.
However, it does not do much change in in process. it took almost 30 min to run 35k rows of data.

Regards,
motherindia.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
Assign Month number 1 to n based on sequential week range
Replies
6
Views
451
amolvijay
A
J
  • Question Question
adding cells based on criteria across several columns
Replies
5
Views
840
Cubist
Cubist
S
  • Solved
Calculate Backdated dates
Replies
5
Views
266
Joe4
Joe4
vinzent
  • Question Question
Formula to get the 4th workday before end of month
Replies
8
Views
421
Tetra201
Tetra201
D
  • Locked
  • Question Question
Could you please write a code for the following scenario?
Replies
1
Views
172
Fluff
Fluff

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

Share this page

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
Back
Top