VBA Code Improvement - Copy if date is less tan today -

M

Mathexcel

New Member
Joined
Jun 22, 2017
Messages
36
Hi,

I am looking to improve this macro as it is really slow to run.

Context:
I want to copy 2 Columns (Room & Price Actual) into my Forecast columns IF the date is less than today.
I need to copy paste with values.

> I am looking for a code that paste using a range method as I believe it will to drastically improve the speed of this macro. > Any ideas on how to do this?


Current Code:
Sub copyif()


Dim Lr As Long, i As Long


Lr = Sheets("FCST").Cells(Rows.Count, 12).End(xlUp).Row

'Start in Row 12
For i = 12 To Lr


If Sheets("FCST").Cells(i, 12).Value < Date Then

'Copy Rooms
Sheets("FCST").Range("AT" & i).Value = Sheets("FCST").Range("AD" & i)
'Copy Price
Sheets("FCST").Range("AV" & i).Value = Sheets("FCST").Range("AF" & i)

End If

Next i




End Sub

Many thanks


:help:
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
Sort by date Sort by votes
Mathexcel said:
Hi,

I am looking to improve this macro as it is really slow to run.

Context:
I want to copy 2 Columns (Room & Price Actual) into my Forecast columns IF the date is less than today.
I need to copy paste with values.

> I am looking for a code that paste using a range method as I believe it will to drastically improve the speed of this macro. > Any ideas on how to do this?

Many thanks


:help:
Click to expand...

Try
Code: 
Sub copyif()


Dim Lr As Long, i As Long, Data_A() As Variant


With Sheets("FCST")


    Lr = .Cells(Rows.count, 12).End(xlUp).Row
    
    'Start in Row 12
    
    Data_A = .Range("A12").Resize(Lr - 12 + 1, 32).Value2
    
    For i = 12 To Lr
    
        If Data_A(i, 12) < Date Then
            'Copy Rooms
            
            .Range("AT" & i).Value2 = Data_A(i, 30)
            'Copy Price
            .Range("AV" & i).Value2 = Data_A(i, 32)
    
        End If
    
    Next i


End With


End Sub
 
Upvote 0
Mathexcel said:
I am looking for a code that paste using a range method as I believe it will to drastically improve the speed of this macro.
Click to expand...

Check if this is faster.

Code: 
Sub copyif()
  Dim i As Long, sh As Worksheet, a() As Variant, b() As Variant
  Set sh = Sheets("FCST")
  a = sh.Range("L12:AF" & sh.Range("L" & Rows.Count).End(xlUp).Row).Value
  ReDim b(1 To UBound(a), 1 To 2)
  For i = 1 To UBound(a)
    If a(i, 1) < Date Then
      b(i, 1) = a(i, 19)
      b(i, 2) = a(i, 21)
    End If
  Next
  sh.Range("AT12").Resize(UBound(a)).Value = Application.Index(b, , 1)
  sh.Range("AV12").Resize(UBound(a)).Value = Application.Index(b, , 2)
End Sub
 
Last edited:
Upvote 0
MoshiM said:
Whoops, change
Code: 
Data_A = .Range("A12").Resize(Lr - 12 + 1, 32).Value2
to
Code: 
Data_A = .Range("A1").Resize(Lr, 32).Value2
Click to expand...


Hi Moshi,

Thanks for your reply. Your code works well, but it took a while to execute.
I need to go through 1000 rows and each paste is then linked to couple more formulas.

I was thinking to try somethink like this:

Find row where Date.Cells.value < Date.
Create range to copy based on the Row.
Paste in the next colum.

I'm no expert in VBA but what do you think?
 
Upvote 0
DanteAmor said:
Check if this is faster.

Code: 
Sub copyif()
  Dim i As Long, sh As Worksheet, a() As Variant, b() As Variant
  Set sh = Sheets("FCST")
  a = sh.Range("L12:AF" & sh.Range("L" & Rows.Count).End(xlUp).Row).Value
  ReDim b(1 To UBound(a), 1 To 2)
  For i = 1 To UBound(a)
    If a(i, 1) < Date Then
      b(i, 1) = a(i, 19)
      b(i, 2) = a(i, 21)
    End If
  Next
  sh.Range("AT12").Resize(UBound(a)).Value = Application.Index(b, , 1)
  sh.Range("AV12").Resize(UBound(a)).Value = Application.Index(b, , 2)
End Sub
Click to expand...

Hi Dante,

Thank you so much for your time, much appreciated. I couldn't run the code due to an "Run-time error'13'" on the "IF a(i, 1) < Date Then" row.

I further checked about this error and it seems to come from the "a(i, 1) = Error 2015". Do you have any idea how to solve this bug?

Other than that, your code seems like what I was looking for!
I also didn't know about the UBound function, thanks for this!

Many thanks,
Matt
 
Upvote 0
Mathexcel said:
"Run-time error'13'" on the "IF a(i, 1) < Date Then" row.
Click to expand...

Hi @Mathexcel,

According to your macro, the dates are in column L and start in row 12, is that correct?

So in column L you only have dates?
Do you have blank spaces or formula errors?
To be sure, you can put an example of the data you have in column L.


Try this and tell me.

For the record only, I tested the macro with 10,000 records and the response is immediate.

Code: 
Sub copyif()
  Dim i As Long, sh As Worksheet, a() As Variant, b() As Variant
  Set sh = Sheets("FCST")
  a = sh.Range("L12:AF" & sh.Range("L" & Rows.Count).End(xlUp).Row).Value
  ReDim b(1 To UBound(a), 1 To 2)
  For i = 1 To UBound(a)
    If Not IsError(a(i, 1)) Then
      If IsDate(a(i, 1)) Then
        If a(i, 1) < Date Then
          b(i, 1) = a(i, 19)
          b(i, 2) = a(i, 21)
        End If
      End If
    End If
  Next
  sh.Range("AT12").Resize(UBound(a)).Value = Application.Index(b, , 1)
  sh.Range("AV12").Resize(UBound(a)).Value = Application.Index(b, , 2)
End Sub
 
Upvote 0
DanteAmor said:
Hi @Mathexcel,

According to your macro, the dates are in column L and start in row 12, is that correct?

So in column L you only have dates?
Do you have blank spaces or formula errors?
To be sure, you can put an example of the data you have in column L.


Try this and tell me.

For the record only, I tested the macro with 10,000 records and the response is immediate.

Code: 
Sub copyif()
  Dim i As Long, sh As Worksheet, a() As Variant, b() As Variant
  Set sh = Sheets("FCST")
  a = sh.Range("L12:AF" & sh.Range("L" & Rows.Count).End(xlUp).Row).Value
  ReDim b(1 To UBound(a), 1 To 2)
  For i = 1 To UBound(a)
    If Not IsError(a(i, 1)) Then
      If IsDate(a(i, 1)) Then
        If a(i, 1) < Date Then
          b(i, 1) = a(i, 19)
          b(i, 2) = a(i, 21)
        End If
      End If
    End If
  Next
  sh.Range("AT12").Resize(UBound(a)).Value = Application.Index(b, , 1)
  sh.Range("AV12").Resize(UBound(a)).Value = Application.Index(b, , 2)
End Sub
Click to expand...

Thanks for this lightspeed reply!:eeek::biggrin:

The code now works! :D
> The only issue is that it deletes the data that is after the date of today, where as I should maintain it as I'm adjusting the forecast on a daily basis.

I don't understand because if the date is < Date, the End If returns to nothing...could you please shed some light on this?

May god bless you!
Best,
Matt
 
Upvote 0
Seriously, you would help a lot if you put a sample of your data, what you have and what you expect from the result, otherwise I'm just guessing.

Try this please.

Code: 
Sub copyif()
  Dim i As Long, sh As Worksheet, a() As Variant, b() As Variant
  Set sh = Sheets("FCST")
  a = sh.Range("L12:AV" & sh.Range("L" & Rows.Count).End(xlUp).Row).Value
  ReDim b(1 To UBound(a), 1 To 2)
  For i = 1 To UBound(a)
    If Not IsError(a(i, 1)) Then
      If IsDate(a(i, 1)) Then
        If a(i, 1) < Date Then
          b(i, 1) = a(i, 19)
          b(i, 2) = a(i, 21)
        Else
          b(i, 1) = a(i, 35)
          b(i, 2) = a(i, 37)
        End If
      End If
    End If
  Next
  sh.Range("AT12").Resize(UBound(a)).Value = Application.Index(b, , 1)
  sh.Range("AV12").Resize(UBound(a)).Value = Application.Index(b, , 2)
End Sub

Response time for a thousand records: 1 second.
 
Upvote 0
Sorry, I forgot to paste the table. The code works perfectly ! Wow smashing! ;D

[TABLE="width: 1771"]
<colgroup><col><col><col><col><col><col><col><col span="2"><col><col><col><col><col span="8"><col><col span="3"></colgroup><tbody>[TR]
[TD]#[/TD]
[TD]#[/TD]
[TD]Year[/TD]
[TD]Month[/TD]
[TD]Month#[/TD]
[TD]Date[/TD]
[TD]Day[/TD]
[TD]DOW[/TD]
[TD]Week[/TD]
[TD]Date LY[/TD]
[TD]Date TY[/TD]
[TD]2019 Invt[/TD]
[TD]2019 OOO[/TD]
[TD]2019 RNs[/TD]
[TD]2019 OCC[/TD]
[TD]2019 ADR[/TD]
[TD]2019 Rev[/TD]
[TD]PU19-RNs[/TD]
[TD]PU19-OCC[/TD]
[TD]PU19-ADR[/TD]
[TD]PU19-Rev[/TD]
[TD]Fcst19RNs[/TD]
[TD]Fcst19OCC[/TD]
[TD]Fcst19ADR[/TD]
[TD]Fcst19Rev[/TD]
[/TR]
[TR]
[TD]28/10/2018[/TD]
[TD]1[/TD]
[TD]2018[/TD]
[TD]October[/TD]
[TD]10[/TD]
[TD]28-Oct[/TD]
[TD]28[/TD]
[TD]Sun[/TD]
[TD]WE[/TD]
[TD]28/10/2017[/TD]
[TD]28/10/2018[/TD]
[TD]39[/TD]
[TD] -[/TD]
[TD]1[/TD]
[TD]2.6%[/TD]
[TD]153.9[/TD]
[TD]154[/TD]
[TD]0[/TD]
[TD]0%[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]1[/TD]
[TD]2.6%[/TD]
[TD]153.9[/TD]
[TD]154[/TD]
[/TR]
[TR]
[TD]29/10/2018[/TD]
[TD]2[/TD]
[TD]2018[/TD]
[TD]October[/TD]
[TD]10[/TD]
[TD]29-Oct[/TD]
[TD]29[/TD]
[TD]Mon[/TD]
[TD]WD[/TD]
[TD]29/10/2017[/TD]
[TD]29/10/2018[/TD]
[TD]39[/TD]
[TD] -[/TD]
[TD]2[/TD]
[TD]5.1%[/TD]
[TD]174.1[/TD]
[TD]348[/TD]
[TD]0[/TD]
[TD]0%[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]2[/TD]
[TD]5.1%[/TD]
[TD]174.1[/TD]
[TD]348[/TD]
[/TR]
[TR]
[TD]30/10/2018[/TD]
[TD]3[/TD]
[TD]2018[/TD]
[TD]October[/TD]
[TD]10[/TD]
[TD]30-Oct[/TD]
[TD]30[/TD]
[TD]Tue[/TD]
[TD]WD[/TD]
[TD]30/10/2017[/TD]
[TD]30/10/2018[/TD]
[TD]39[/TD]
[TD] -[/TD]
[TD]4[/TD]
[TD]10.3%[/TD]
[TD]203.4[/TD]
[TD]814[/TD]
[TD]0[/TD]
[TD]0%[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]4[/TD]
[TD]10.3%[/TD]
[TD]203.4[/TD]
[TD]814[/TD]
[/TR]
[TR]
[TD]31/10/2018[/TD]
[TD]4[/TD]
[TD]2018[/TD]
[TD]October[/TD]
[TD]10[/TD]
[TD]31-Oct[/TD]
[TD]31[/TD]
[TD]Wed[/TD]
[TD]WD[/TD]
[TD]31/10/2017[/TD]
[TD]31/10/2018[/TD]
[TD]39[/TD]
[TD] -[/TD]
[TD]10[/TD]
[TD]25.6%[/TD]
[TD]154.2[/TD]
[TD]1 542[/TD]
[TD]0[/TD]
[TD]0%[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]10[/TD]
[TD]25.6%[/TD]
[TD]154.2[/TD]
[TD]1 542[/TD]
[/TR]
[TR]
[TD]01/11/2018[/TD]
[TD]5[/TD]
[TD]2018[/TD]
[TD]November[/TD]
[TD]11[/TD]
[TD]01-Nov[/TD]
[TD]1[/TD]
[TD]Thu[/TD]
[TD]WD[/TD]
[TD]01/11/2017[/TD]
[TD]01/11/2018[/TD]
[TD]39[/TD]
[TD] -[/TD]
[TD]37[/TD]
[TD]94.9%[/TD]
[TD]164.9[/TD]
[TD]6 099[/TD]
[TD]0[/TD]
[TD]0%[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]37[/TD]
[TD]94.9%[/TD]
[TD]164.9[/TD]
[TD]6 099[/TD]
[/TR]
[TR]
[TD]02/11/2018[/TD]
[TD]6[/TD]
[TD]2018[/TD]
[TD]November[/TD]
[TD]11[/TD]
[TD]02-Nov[/TD]
[TD]2[/TD]
[TD]Fri[/TD]
[TD]WE[/TD]
[TD]02/11/2017[/TD]
[TD]02/11/2018[/TD]
[TD]39[/TD]
[TD] -[/TD]
[TD]33[/TD]
[TD]84.6%[/TD]
[TD]149.9[/TD]
[TD]4 945[/TD]
[TD]0[/TD]
[TD]0%[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]33[/TD]
[TD]84.6%[/TD]
[TD]149.9[/TD]
[TD]4 945[/TD]
[/TR]
[TR]
[TD]03/11/2018[/TD]
[TD]7[/TD]
[TD]2018[/TD]
[TD]November[/TD]
[TD]11[/TD]
[TD]03-Nov[/TD]
[TD]3[/TD]
[TD]Sat[/TD]
[TD]WE[/TD]
[TD]03/11/2017[/TD]
[TD]03/11/2018[/TD]
[TD]39[/TD]
[TD] -[/TD]
[TD]38[/TD]
[TD]97.4%[/TD]
[TD]163.7[/TD]
[TD]6 221[/TD]
[TD]0[/TD]
[TD]0%[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]38[/TD]
[TD]97.4%[/TD]
[TD]163.7[/TD]
[TD]6 221[/TD]
[/TR]
[TR]
[TD]04/11/2018[/TD]
[TD]8[/TD]
[TD]2018[/TD]
[TD]November[/TD]
[TD]11[/TD]
[TD]04-Nov[/TD]
[TD]4[/TD]
[TD]Sun[/TD]
[TD]WE[/TD]
[TD]04/11/2017[/TD]
[TD]04/11/2018[/TD]
[TD]39[/TD]
[TD] -[/TD]
[TD]22[/TD]
[TD]56.4%[/TD]
[TD]165.4[/TD]
[TD]3 639[/TD]
[TD]0[/TD]
[TD]0%[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]22[/TD]
[TD]56.4%[/TD]
[TD]165.4[/TD]
[TD]3 639[/TD]
[/TR]
[TR]
[TD]05/11/2018[/TD]
[TD]9[/TD]
[TD]2018[/TD]
[TD]November[/TD]
[TD]11[/TD]
[TD]05-Nov[/TD]
[TD]5[/TD]
[TD]Mon[/TD]
[TD]WD[/TD]
[TD]05/11/2017[/TD]
[TD]05/11/2018[/TD]
[TD]39[/TD]
[TD] -[/TD]
[TD]36[/TD]
[TD]92.3%[/TD]
[TD]199.6[/TD]
[TD]7 187[/TD]
[TD]0[/TD]
[TD]0%[/TD]
[TD]0[/TD]
[TD]0[/TD]
[TD]36[/TD]
[TD]92.3%[/TD]
[TD]199.6[/TD]
[TD]7 187[/TD]
[/TR]
</tbody>[/TABLE]
An
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Solved
VBA Copying Into/Out of An Array Between Workbooks
Replies
4
Views
127
Peter_SSs
Peter_SSs
P
  • Question Question
For Each Loop with copy and paste over multiple worksheets
Replies
1
Views
148
Sam_D_Ben
Sam_D_Ben
A
  • Solved
need procedure by message box to inform what exactly missed month
Replies
2
Views
74
Ali M
A
C
  • Solved
VBA - Copy and paste a range of values N times
Replies
6
Views
559
cydmm
C
A
  • Question Question
Copy paste column based on range from another column
Replies
7
Views
304
Aviles
A

Forum statistics

Threads
1,226,730
Messages
6,192,708
Members
453,748
Latest member
akhtarf3

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