How to create a macro that copy pastes a fix range into another sheet and takes into consideration a cell value

C

CuriousFox

New Member
Joined
Nov 1, 2022
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Hello!

I'm pulling from Yahoo Finance the historical stock prices. You can only get with Power Query 100 lines. I have downloaded the history in one sheet and I have the Power Query with the last 100 days in another sheet. I would like to have a macro that pastes the new values into the history sheet only if they come after the values already saved in the history.

For example below in Table 0 it should only copy into Sheet1 the last month:

1667323082773.png
1667323129477.png


My knowledge of VBA is quite basic, and I can only make a normal copy paste as below. Could any genious please help me with the correct and more complex VBA to achieve it?

Sub valuepaste()
Worksheets("AAPL").Range("Table_0").Copy
Worksheets("Sheet1").Range("A2").PasteSpecial Paste:=xlPasteValues
End Sub

Infinite thanks
 

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.
Sort by date Sort by votes
Try this code :

VBA Code: 
Sub CopyLastMonth()
    Application.ScreenUpdating = False
    Dim FTws As Worksheet, srcWS As Worksheet
    Set FTws = ThisWorkbook.Sheets("Sheet1")
    Set srcWS = ThisWorkbook.Sheets("Table 0")
    Dim lastRow As Long, i As Long, header As Range, x As Long
    lastRow = srcWS.Range("A" & srcWS.Rows.Count).End(xlUp).Row
    With srcWS
        .Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=xlFilterLastMonth, Operator:=xlFilterDynamic
        With .Range("A:A,B:B,C:C,D:D,E:E,F:F,G:G")
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = FTws.Rows(2).Find(.Areas(i).Cells(1), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    Intersect(srcWS.Range(srcWS.Cells(3, x), srcWS.Cells(lastRow, x)), srcWS.AutoFilter.Range).Copy FTws.Cells(FTws.Rows.Count, header.Column).End(xlUp).Offset(1, 0)
                End If
            Next i
        End With
    End With
    srcWS.Range("A2").AutoFilter
    Application.ScreenUpdating = True

End Sub
 
Upvote 0
Hi Flaiban!

Thank you so much for this. I think the code is almost there. It almost does fully the job, I see that it only copies until 31/10/2022 and when I update the Power Query to get recent data it doesn't take into consideration the last inputs (01/11 and 02/11). Also if I run the code a second time instead of pasting the new info or nothing, it pastes again the same selection.

I would love to be able to tweak your code but it's too advanced for me at this point. Is there a work around these small issues?

Thank you again for your help!
 
Upvote 0
Let's go..Chenged code :

VBA Code: 
Sub CopyLastMonth()
    Application.ScreenUpdating = False
    Dim FTws As Worksheet, srcWS As Worksheet
    
    Set FTws = ThisWorkbook.Sheets("Sheet1")
    Set srcWS = ThisWorkbook.Sheets("Table 0")
    Dim lastRow As Long, i As Long, j As Long, header As Range, x As Long, LrowSheet1 As Long
    Dim CurrentDate As Long
    Dim LastDate As Long

    CurrentDate = DateSerial(Year(Now), Month(Now), 1)
    LastDate = Evaluate("=Edate(" & CurrentDate & ",-1)")
    
    LrowSheet1 = FTws.Range("A65356").End(xlUp).Row
    lastRow = srcWS.Range("A" & srcWS.Rows.Count).End(xlUp).Row
    With FTws
        For j = LrowSheet1 To 3 Step -1
            If FTws.Cells(j, 1) <> "" Then
                FTws.Rows(j).EntireRow.Delete
            End If
        Next j
    End With
    With srcWS
        .Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:="=" & CurrentDate, Operator:=xlAnd, Criteria2:=">=" & LastDate
        With .Range("A:A,B:B,C:C,D:D,E:E,F:F,G:G")
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = FTws.Rows(2).Find(.Areas(i).Cells(1), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    Intersect(srcWS.Range(srcWS.Cells(2, x), srcWS.Cells(lastRow, x)), srcWS.AutoFilter.Range).Copy FTws.Cells(FTws.Rows.Count, header.Column).End(xlUp).Offset(1, 0)
                End If
            Next i
        End With
    End With
    srcWS.Range("A2").AutoFilter
    Application.ScreenUpdating = True

End Sub
 
Upvote 0
Flaiban said:
Let's go..Changed code :

VBA Code: 
Sub CopyLastMonth()
    Application.ScreenUpdating = False
    Dim FTws As Worksheet, srcWS As Worksheet
    
    Set FTws = ThisWorkbook.Sheets("Sheet1")
    Set srcWS = ThisWorkbook.Sheets("Table 0")
    Dim lastRow As Long, i As Long, j As Long, header As Range, x As Long, LrowSheet1 As Long

    
    LrowSheet1 = FTws.Range("A65356").End(xlUp).Row
    lastRow = srcWS.Range("G" & srcWS.Rows.Count).End(xlUp).Row
    
    With FTws
        For j = LrowSheet1 To 3 Step -1
            If FTws.Cells(j, 1) <> "" Then
                FTws.Rows(j).EntireRow.Delete
            End If
        Next j
    End With
    With srcWS
        .Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=">" & Application.EoMonth(Now, -2), Operator:=xlAnd, Criteria2:="<=" & Application.EoMonth(Now, 0)
        With .Range("A:A,B:B,C:C,D:D,E:E,F:F,G:G")
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = FTws.Rows(2).Find(.Areas(i).Cells(1), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    Intersect(srcWS.Range(srcWS.Cells(2, x), srcWS.Cells(lastRow, x)), srcWS.AutoFilter.Range).Copy FTws.Cells(FTws.Rows.Count, header.Column).End(xlUp).Offset(1, 0)
                End If
            Next i
        End With
    End With
    srcWS.Range("A2").AutoFilter
    Application.ScreenUpdating = True

End Sub
Click to expand...
 
Upvote 0
Thank you for your quick reply. I appreciate you! I cannot see the results yet, I get an error "91 Object variable or With block variable not set". Using the debug it shows the last paragraph line "Intersect(srcWS.Range(srcWS.Cells(2, x), srcWS.Cells(lastRow, x)), srcWS.AutoFilter.Range).Copy FTws.Cells(FTws.Rows.Count, header.Column).End(xlUp).Offset(1, 0)"
 
Upvote 0
That's weird...🤔...it's OK for me .
Did you try this code too?
VBA Code: 
Sub CopyLastMonth()
    Application.ScreenUpdating = False
    Dim FTws As Worksheet, srcWS As Worksheet
    
    Set FTws = ThisWorkbook.Sheets("Sheet1")
    Set srcWS = ThisWorkbook.Sheets("Table 0")
    Dim lastRow As Long, i As Long, j As Long, header As Range, x As Long, LrowSheet1 As Long

    
    LrowSheet1 = FTws.Range("A65356").End(xlUp).Row
    lastRow = srcWS.Range("G" & srcWS.Rows.Count).End(xlUp).Row
    
    With FTws
        For j = LrowSheet1 To 3 Step -1
            If FTws.Cells(j, 1) <> "" Then
                FTws.Rows(j).EntireRow.Delete
            End If
        Next j
    End With
    With srcWS
        .Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=">" & Application.EoMonth(Now, -2), Operator:=xlAnd, Criteria2:="<=" & Application.EoMonth(Now, 0)
        With .Range("A:A,B:B,C:C,D:D,E:E,F:F,G:G")
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = FTws.Rows(2).Find(.Areas(i).Cells(1), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    Intersect(srcWS.Range(srcWS.Cells(2, x), srcWS.Cells(lastRow, x)), srcWS.AutoFilter.Range).Copy FTws.Cells(FTws.Rows.Count, header.Column).End(xlUp).Offset(1, 0)
                End If
            Next i
        End With
    End With
    srcWS.Range("A2").AutoFilter
    Application.ScreenUpdating = True

End Sub
 
Upvote 0
Flaiban said:
That's weird...🤔...it's OK for me .
Did you try this code too?
VBA Code: 
Sub CopyLastMonth()
    Application.ScreenUpdating = False
    Dim FTws As Worksheet, srcWS As Worksheet
   
    Set FTws = ThisWorkbook.Sheets("Sheet1")
    Set srcWS = ThisWorkbook.Sheets("Table 0")
    Dim lastRow As Long, i As Long, j As Long, header As Range, x As Long, LrowSheet1 As Long

   
    LrowSheet1 = FTws.Range("A65356").End(xlUp).Row
    lastRow = srcWS.Range("G" & srcWS.Rows.Count).End(xlUp).Row
   
    With FTws
        For j = LrowSheet1 To 3 Step -1
            If FTws.Cells(j, 1) <> "" Then
                FTws.Rows(j).EntireRow.Delete
            End If
        Next j
    End With
    With srcWS
        .Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=">" & Application.EoMonth(Now, -2), Operator:=xlAnd, Criteria2:="<=" & Application.EoMonth(Now, 0)
        With .Range("A:A,B:B,C:C,D:D,E:E,F:F,G:G")
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = FTws.Rows(2).Find(.Areas(i).Cells(1), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    Intersect(srcWS.Range(srcWS.Cells(2, x), srcWS.Cells(lastRow, x)), srcWS.AutoFilter.Range).Copy FTws.Cells(FTws.Rows.Count, header.Column).End(xlUp).Offset(1, 0)
                End If
            Next i
        End With
    End With
    srcWS.Range("A2").AutoFilter
    Application.ScreenUpdating = True

End Sub
Click to expand...
Indeed it's weird. It does work with the example Excel I created (however if I run the macro for a second time it pastes the selection again). If I change the names of the sheets having the tables in the same exact place there I get the error. I can't figure out why
 
Upvote 0
CuriousFox said:
Indeed it's weird. It does work with the example Excel I created (however if I run the macro for a second time it pastes the selection again). If I change the names of the sheets having the tables in the same exact place there I get the error. I can't figure out why
Click to expand...
I need to see better what's with this code
 
Upvote 0
And now :

VBA Code: 
Sub TestFilter()

Dim ws As Worksheet
Dim ws2 As Worksheet
Dim j As Long, LrowSheet1 As Long

Set ws = ThisWorkbook.Sheets("Table 0")
Set ws2 = ThisWorkbook.Sheets("Sheet1")

LrowSheet1 = ws2.Range("A65356").End(xlUp).Row

    With ws2
        For j = LrowSheet1 To 3 Step -1
            If ws2.Cells(j, 1) <> "" Then
                ws2.Rows(j).EntireRow.Delete
            End If
        Next j
    End With
    
ws.AutoFilterMode = False
With ws
    .Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=">" & Application.EoMonth(Now, -2), Operator:=xlAnd, Criteria2:="<=" & Application.EoMonth(Now, 0)
End With
ws.Range("A2:G" & Cells(Rows.Count, 1).End(xlUp).Row).Copy

ws2.Range("A3").PasteSpecial Paste:=xlPasteAll

ws.Range("A2").AutoFilter
Application.CutCopyMode = False

End Sub


A little simpler
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
How to automatically paste the data from one sheet to another using VBA
Replies
4
Views
235
Alex Blakenburg
A
M
  • Solved
VBA - how to add a copy and paste values on current module
Replies
2
Views
115
Minx_Minxy
M
J
  • Solved
Copy /past cells by inputbox on sheet 2 to sheet1 using VBA
2
Replies
12
Views
500
DanteAmor
DanteAmor
F
  • Solved
Copy paste from one Excel workbook to another with same sheet names and update dates in range
Replies
8
Views
514
Skiier89
S
M
  • Solved
cut/copy and paste row based on cell value not being equal to specific text
Replies
6
Views
493
mlan1604
M

Forum statistics

Threads
1,223,889
Messages
6,175,224
Members
452,620
Latest member
dsubash

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