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

motherindia · Aug 23, 2017

Dear Sir,

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

Unique No	S Date	E Date	Amt	Type
1	01-Apr-17	30-Jun-17	100	A
1	01-Jul-17	31-Mar-18	150	B
2	01-Apr-17	30-Apr-17	100	A
2	01-May-17	31-May-17	200	B
2	01-Jun-17	30-Jun-17	300	A
2	01-Jul-17	31-Jul-17	400	B
2	01-Aug-17	31-Aug-17	500	B

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

Amt

Type

Unique No

Apr-17

May-17

Jun-17

Jul-17

Aug-17

Sep-17

Oct-17

Nov-17

Dec-17

Jan-18

Feb-18

Mar-18

Apr-17

May-17

Jun-17

Jul-17

Aug-17

Sep-17

Oct-17

Nov-17

Dec-17

Jan-18

Feb-18

Mar-18

1

100

150

A

B

2

100

200

300

400

500

A

B

A

B

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

Kindly do the needful.

regards,
motherindia </tbody>

wideboydixon · Aug 23, 2017

Book1

A

B

C

D

E

1

Unique No

S Date

E Date

Amt

Type

2

1

01-Apr-17

30-Jun-17

100

A

3

1

01-Jul-17

31-Mar-18

150

B

4

2

01-Apr-17

30-Apr-17

100

A

5

2

01-May-17

31-May-17

200

B

6

2

01-Jun-17

30-Jun-17

300

A

7

2

01-Jul-17

31-Jul-17

400

B

8

2

01-Aug-17

31-Aug-17

500

B

Sheet1

Book1

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

W

X

Y

1

Amt

Type

2

Unique No

Apr-17

May-17

Jun-17

Jul-17

Aug-17

Sep-17

Oct-17

Nov-17

Dec-17

Jan-18

Feb-18

Mar-18

Apr-17

May-17

Jun-17

Jul-17

Aug-17

Sep-17

Oct-17

Nov-17

Dec-17

Jan-18

Feb-18

Mar-18

3

1

4

2

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

motherindia · Aug 23, 2017

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

wideboydixon · Aug 23, 2017

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

motherindia · Aug 23, 2017

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

motherindia · Aug 24, 2017

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.

wideboydixon · Aug 24, 2017

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

motherindia · Aug 24, 2017

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

Biz · Aug 24, 2017

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

motherindia · Aug 25, 2017

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.

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

motherindia

Board Regular

Excel Facts

wideboydixon

Well-known Member

motherindia

Board Regular

wideboydixon

Well-known Member

motherindia

Board Regular

motherindia

Board Regular

wideboydixon

Well-known Member

motherindia

Board Regular

Biz

Well-known Member

motherindia

Board Regular

Similar threads

Forum statistics

Share this page

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

Board Regular

Excel Facts

Well-known Member

Board Regular

Well-known Member

Board Regular

Board Regular

Well-known Member

Board Regular

Well-known Member

Board Regular

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock