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

 

[ssh99]

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

Please see the 2 links below. The DestinationSheet is where the data is copied to and House Name Data is the original dataset.

house name data.xlsm

Microsoft Excel Workbook

1drv.ms

DestinationSheet.xlsx

Microsoft Excel Workbook

1drv.ms

 

[kevin9999]

Another option.

Option Explicit
Sub HouseData()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Dim d As Object, arr, i As Long
    Set d = CreateObject("scripting.dictionary")
    arr = ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))
    For i = 1 To UBound(arr, 1)
        d(arr(i, 1)) = 1
    Next i
    
    Dim a, OpenFile As String, wb As Workbook, WsDest As Worksheet
    a = d.keys
    For i = LBound(a) To UBound(a)
        OpenFile = "C:\Users\SAHU11\OneDrive - NHS\Desktop\test\" & a(i) & ".xlsx"
        If Dir(OpenFile) <> "" Then
            Set wb = Workbooks.Open(OpenFile)
            Set WsDest = wb.Worksheets(1)
            With ws.Range("A1").CurrentRegion
                .AutoFilter 1, a(i)
                .Offset(1).Resize(.Rows.Count - 1, 15).Copy
                WsDest.Range("B5").PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                .AutoFilter
            End With
            wb.Close True
        Else
            MsgBox a(i) & " was not found."
        End If
    Next i
End Sub

 

[ssh99]

Another option.

Option Explicit
Sub HouseData()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Dim d As Object, arr, i As Long
    Set d = CreateObject("scripting.dictionary")
    arr = ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))
    For i = 1 To UBound(arr, 1)
        d(arr(i, 1)) = 1
    Next i
   
    Dim a, OpenFile As String, wb As Workbook, WsDest As Worksheet
    a = d.keys
    For i = LBound(a) To UBound(a)
        OpenFile = "C:\Users\SAHU11\OneDrive - NHS\Desktop\test\" & a(i) & ".xlsx"
        If Dir(OpenFile) <> "" Then
            Set wb = Workbooks.Open(OpenFile)
            Set WsDest = wb.Worksheets(1)
            With ws.Range("A1").CurrentRegion
                .AutoFilter 1, a(i)
                .Offset(1).Resize(.Rows.Count - 1, 15).Copy
                WsDest.Range("B5").PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                .AutoFilter
            End With
            wb.Close True
        Else
            MsgBox a(i) & " was not found."
        End If
    Next i
End Sub

Thank you. Just one problem - I need the vba to take the file name from column A but only copy and paste columns B-P. Do you know where I need to amend the code?

 

[kevin9999]

Thank you. Just one problem - I need the vba to take the file name from column A but only copy and paste columns B-P. Do you know where I need to amend the code?

I'm away from my laptop, but try changing. Offset(1) to .Offset(1,1)

 

[kevin9999]

Do you know where I need to amend the code?

Change this line:

.Offset(1).Resize(.Rows.Count - 1, 15).Copy

To this:

.Offset(1,1).Resize(.Rows.Count - 1, 15).Copy

 

[ssh99]

Change this line:

.Offset(1).Resize(.Rows.Count - 1, 15).Copy

To this:

.Offset(1,1).Resize(.Rows.Count - 1, 15).Copy

Thank you so much! This will save me so much time.

 

[kevin9999]

Thank you so much! This will save me so much time.

Glad we helped, and thanks for the feedback