VBA to copy rows containing data to another workbook

antrixx

New Member
Joined
Jun 23, 2021
Messages
7
Office Version
  1. 2019
  2. 2016
  3. 2013
Platform
  1. Windows
Hi All,

I've made 2 example spreadsheets to show what I'm trying to do, and I'm almost there, but stuck on the last bit.

VBA code for the filtered workbook buttons are at the bottom

I'm trying to copy rows from the main workbook ('Inventory.xlsm') from specific pages (in the example, pages 'AA.BB', 'CC.DD' and 'GG.HH'), to another workbook ('Filtered.xlsm') with the data on sheet ('FilteredData').
The spreadsheet that it will be eventually used on will contain hundreds of pages, so the page names need to be specific as it will only need to pull the data from those specific pages.
The main workbook in this example ('Inventory.xlsm') cannot be amended, only the workbook ('Filtered.xlsm') can be changed to get this data.

From the main workbook, ('Inventory.xlsm'), I want to copy the rows where column I is not zero (columns to copy are B to I, but column G takes the minimum date from column N to O), between rows 2 and 99 (this also needs to be specific rows as there is other data above and below on the actual real workbook). The data between rows 2 and 99 will start at row 2, and continue down line by line. Once a blank line is reached between 2 and 99, there will be nothing else below that row that is needed. This data needs to be copied to the new workbook ('Filtered.xlsm').

As you can see from the screenshots, I have a button to press that takes the data from the main workbook specific pages, and copies it to the new filtered workbook (in to columns A to H). It then filters the new column H to exclude zero, only leaving the data 1 or above.

In my example, everything that I want to copy seems to copy fine, except for column F which is a date, as this is copied as the main workbook formula which no longer has the 2 dates to choose the minimum date from. I've tried putting in PasteSpecial Paste:=xlPasteValues which was suggested from other problems that I've seen people having, but I can't figure out where to put it as I've tried many places in the code and it just throws up errors.

So my question is:

1) How can I copy the data so the date copies what the 'Inventory.xlsm' workbook says, and not the formula which will then try to reference incorrect cells on the new filtered workbook.

2) If there's a better way to copy the original data to only copy the rows where I is not zero instead of copying everything and then filtering, I'm open to help on this too.

If you got this far, thanks in advance :)

David.


Sub Macro1()

Dim lr As Long, lc As Long, lr2 As Long
Dim arr As Variant, sh As Variant
Dim sPrint As Worksheet

On Error GoTo Start
ActiveWorkbook.ActiveSheet.ShowAllData

Start:
Application.ScreenUpdating = False
Set sPrint = Sheets("FilteredData")
sPrint.Cells.Clear

Workbooks("Inventory.xlsm").Activate

arr = Array("AA.BB", "CC.DD", "GG.HH")

lr2 = 4
For Each sh In arr
With Sheets(sh)
lr = .Range("B" & Rows.Count).End(3).Row

lc = .Cells(4, 9).End(3).Column

.Range("B1", .Cells(lr, lc)).Copy sPrint.Range("A" & lr2)

lr2 = sPrint.Range("B" & Rows.Count).End(3).Row + 3

End With

Next

Application.ScreenUpdating = True

Selection.Copy

Windows("Filtered.xlsm").Activate

On Error GoTo Protection
If ActiveWorkbook.ActiveSheet.FilterMode Or _
ActiveWorkbook.ActiveSheet.AutoFilterMode Then _
ActiveWorkbook.ActiveSheet.ShowAllData.PasteSpecial Paste:=xlPasteValues
Workbooks("Filtered.xlsm").Activate

ActiveSheet.Range("$A$4:$H$285").AutoFilter Field:=8, Criteria1:="<>0"
Range("A1").Select
Exit Sub
Protection:
If Err.Number = 1004 And Err.Description = _
"ShowAllData method of Worksheet class failed" Then
MsgBox "There are no filters to clear!", _
vbInformation
ActiveSheet.Range("$B$7:$I$285").AutoFilter Field:=8, Criteria1:="<>0"
End If

Workbooks("Filtered.xlsm").Activate
Range("A1").Select


End Sub

Sub ClearData()

On Error GoTo Start
ActiveSheet.ShowAllData
Start:
ActiveSheet.Cells.Clear

End Sub
 

Attachments

  • inventoryexample-screenshot.jpg
    inventoryexample-screenshot.jpg
    133.2 KB · Views: 23
  • filteredexample-screenshot.jpg
    filteredexample-screenshot.jpg
    117.8 KB · Views: 23

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!

Forum statistics

Threads
1,223,900
Messages
6,175,276
Members
452,629
Latest member
SahilPolekar

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