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

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney
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

F
  • Question
VBA to determine range of data at left side and copy it to the right side of Excel sheet.
Replies
4
Views
276
kevin9999
K
V
  • Solved
VBA Macro Copy and Paste
Replies
3
Views
450
kevin9999
K
N
  • Question
VBA Questions - Copying dynamic data from one tab to another and deleting filtered rows
Replies
1
Views
191
DanteAmor
DanteAmor
S
  • Question
Program Button to Find, Copy, Paste to New Sheet based on Value in column
Replies
0
Views
161
samss919
S
V
  • Question
VBA Code to copy rows from one sheet to another dynamically
2
Replies
11
Views
926
Joe4
Joe4

Forum statistics

Threads
1,215,106
Messages
6,123,124
Members
449,097
Latest member
mlckr

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