VBA filter and copy and paste to another workbook

[ssh99]

I have written VBA to do the following:
1) Find a workbook named after the House Name in column A.
2) Copy and paste the contents of columns A-P to the workbook. Data should be pasted in cell B5 onwards.

The problem I have is that in my spreadsheet a House Name can have multiple rows of data. I need all the rows to be copied to the individual workbooks. Would it be possible to:
1) Filter column A for each of the House Names and paste all filtered results to the individual workbooks. . Data should be pasted in cell B5 onwards.
2) Paste values only?

I have attached a screenshot of the dataset (all records are fictional). I can provide a copy of the spreadsheet if this is helpful.

The VBA I currently have is:

Sub CopyPasteData()
Dim previousAlertsFlag As Boolean
Dim masterWB As Workbook
Dim masterWS As Worksheet
Dim destWB As Workbook
Dim destWS As Worksheet
Dim lastRow As Long
Dim filepath As String
Dim fullpath As String
Dim r As Integer

Set masterWB = ThisWorkbook
Set masterWS = masterWB.Worksheets("Sheet1")
lastRow = masterWS.Cells(masterWS.Rows.Count, "A").End(xlUp).Row
filepath = "C:\Users\SAHU11\OneDrive - NHS\Desktop\test\"

For r = 2 To lastRow
User = masterWS.Cells(r, 1).Value
fullpath = filepath & User
Set destWB = Workbooks.Open(fullpath)
Set destWS = destWB.Sheets("Sheet1")
masterWS.Cells(r, 2).Resize(, 15).Copy destWS.Cells(5, 2)
destWB.Close SaveChanges:=True

Next r

End Sub

 

[kevin9999]

I can provide a copy of the spreadsheet if this is helpful.

Yes please.

 

[Mario_R]

Hello. Perhaps the following can help you:

Sub CopyPasteData()
Dim Rng As Range, filePath$, mFile, C As Range
'------------->
Set Rng = Range("'Sheet1'!A1").CurrentRegion.Columns("A:P")
Rng.Columns(1).AdvancedFilter 2, Empty, Rng.Worksheet.[z1], True
filePath = "C:\Users\SAHU11\OneDrive - NHS\Desktop\test\"
'------------->
For Each C In Rng.Worksheet.[z1].CurrentRegion
  If C.Row > 1 Then
    If Dir(filePath & C & "*.xl*") = "" Then
      MsgBox "File not found:" & vbLf & vbTab & vbTab & "<" & C & ">."
      Rng.Worksheet.[z1].EntireColumn.Delete
      End
    End If
  End If
Next
'------------->
Do Until Rng.Worksheet.[z2] = ""
  mFile = Dir(filePath & Rng.Worksheet.[z2] & "*.xl*")
  With Workbooks.Open(filePath & mFile).Sheets(1)
    .Range("A5").Resize(, Rng.Columns.Count).ClearContents
    Rng.AdvancedFilter 2, Rng.Worksheet.Range("Z1:Z2"), .Range("A5"), False
    .Parent.Close True
  End With
  Rng.Worksheet.[z2].Delete xlShiftUp
Loop
'------------->
Rng.Worksheet.[z1].EntireColumn.Delete
End Sub

 

[ssh99]

Yes please.

Thanks for your reply. Here is the link to the file on OneDrive:

house name data.xls

Microsoft Excel Workbook

1drv.ms

 

[ssh99]

Hello. Perhaps the following can help you:

Sub CopyPasteData()
Dim Rng As Range, filePath$, mFile, C As Range
'------------->
Set Rng = Range("'Sheet1'!A1").CurrentRegion.Columns("A:P")
Rng.Columns(1).AdvancedFilter 2, Empty, Rng.Worksheet.[z1], True
filePath = "C:\Users\SAHU11\OneDrive - NHS\Desktop\test\"
'------------->
For Each C In Rng.Worksheet.[z1].CurrentRegion
  If C.Row > 1 Then
    If Dir(filePath & C & "*.xl*") = "" Then
      MsgBox "File not found:" & vbLf & vbTab & vbTab & "<" & C & ">."
      Rng.Worksheet.[z1].EntireColumn.Delete
      End
    End If
  End If
Next
'------------->
Do Until Rng.Worksheet.[z2] = ""
  mFile = Dir(filePath & Rng.Worksheet.[z2] & "*.xl*")
  With Workbooks.Open(filePath & mFile).Sheets(1)
    .Range("A5").Resize(, Rng.Columns.Count).ClearContents
    Rng.AdvancedFilter 2, Rng.Worksheet.Range("Z1:Z2"), .Range("A5"), False
    .Parent.Close True
  End With
  Rng.Worksheet.[z2].Delete xlShiftUp
Loop
'------------->
Rng.Worksheet.[z1].EntireColumn.Delete
End Sub

Thank you! This is almost there. Only problem is I need the vba to take the file name from column A but only copy and paste columns B-P. The header row also shouldn't be copied.

I tried to amend the code you've sent but an error comes up.

 

[kevin9999]

Thanks for your reply. Here is the link to the file on OneDrive:

Unfortunately, the file won't open - gets stuck on "Converting your file so you can edit it..."

 

[Mario_R]

I tried to amend the code you've sent but an error comes up.

Please: show the lines of code you tried and failed...

 

[ssh99]

Please: show the lines of code you tried and failed...

Set Rng = Range("'Sheet1'!A1").CurrentRegion.Columns("A:P")

I tried changing the mapping to column B but an error comes up saying 'the extract range has a missing or invalid field name'. I realise I'm probably trying to edit the wrong part of the code.

 

[ssh99]

Unfortunately, the file won't open - gets stuck on "Converting your file so you can edit it..."

That's strange. I just tried to open it and it opened after a few seconds on the page you saw.

 

[Mario_R]

I need to see what you have in row 5 and column A of each file that receives the copy.