Copy Specific Range from one workbook to another based on condition

Question

Thanks for taking the time to read this. I have a Master contact workbook containing a list of people who need follow up calls. In the very first column of this workbook the initials of the person being assigned the follow-up call are listed (example: CWS). What I want is a formula that will scan all cells in the first column for a set of initials, and then copy the data from columns E through J to a new workbook assigned specifically to that case manager. The code below is just a skeleton, but it was enough to do a small test run. I haven't touched VBA in 10 years so I'm sure it's far from perfect

Sub MoveContactInfo()
Dim xrow As Long
xrow = 4
Sheets("Master Data Set").Select
Dim lastrow As Long
lastrow = Cells(Rows.Count, 1).End(x1Up).Row
Dim rng As Range

Do Until xrow = lastrow + 1
    ActiveSheet.Cells(xrow, 1).Select
    If ActiveCell.Text = "CWS" Then
    rng = Range(Cells(xrow, 5), Cells(xrow, 10))
    rng.Copy
    Workbooks.Open Filename:="D:\My Documents\Excel Spreadsheets\TEST.xls"
    Worksheets("CWS").Select
    Cells(4, 1).PasteSpecial
    End If

xrow = xrow + 1
Loop

End Sub

Thanks so much for the help. Please let me know if there's anything else I can clarify. For now, I'm just trying to paste to a test workbook I've created filled with worksheets named after each Case Manager.

Answer 1

I would avoid the Do Loop if you're only searching for a single value one time. If you need to modify it to search for the same value more then once, you'll find some good examples of using Range().FindNext here: Range.FindNext Method (Excel) .

Sub MoveContactInfo()
    Dim Search As String
    Dim f As Range
    Dim wb As Workbook
    Search = "CWS"
    With Sheets("Master Data Set")
        Set f = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Find(What:=Search, After:=Range("A1"), LookAt:=xlWhole, MatchCase:=False)

        If Not f Is Nothing Then
            Set wb = Workbooks.Open(FileName:="D:\My Documents\Excel Spreadsheets\TEST.xls")

            If Not wb Is Nothing Then

                On Error Resume Next

                    f.EntireRow.Columns("E:J").Copy wb.Worksheets(Search).Cells(4, 1)

                On Error GoTo 0
            End If

        End If

    End With

End Sub

---

UPDATE: The OP states in a comment that there are multiple records that need to be copied.

I modified the code to collect the data in an array and write the data to the range in a single operation.

Sub MoveContactInfo()
    Dim Search As String
    Dim f As Range
    Dim Data() As Variant
    Dim x As Long
    Dim wb As Workbook, ws As Worksheet
    Search = "CWS"

    ReDim Data(5, x)

    With Sheets("Master Data Set")
        For Each f In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
            If f.Value = Search Then
                ReDim Preserve Data(6, x)

                Data(0, x) = f(1, "E")
                Data(1, x) = f(1, "F")
                Data(2, x) = f(1, "G")
                Data(3, x) = f(1, "H")
                Data(4, x) = f(1, "I")
                Data(5, x) = f(1, "J")

                x = x + 1
            End If


        Next


        If Not f Is Nothing Then
            Set wb = Workbooks.Open(Filename:="D:\My Documents\Excel Spreadsheets\TEST.xls")

            If Not wb Is Nothing Then

                On Error Resume Next
                Set ws = wb.Worksheets(Search)
                On Error GoTo 0

                If ws Is Nothing Then
                    MsgBox "Worksheet not found-> " & Search, vbInformation, "Retry"
                Else
                    ws.Cells(4, 1).Resize(UBound(Data, 2), UBound(Data, 1)) = Application.Transpose(Data)
                End If
            End If

        End If

    End With

End Sub

Answer 2

Tidied a few things up. You were pretty close, good effort with being out so long.

Sub MoveContactInfo()
Dim xrow As Long
Dim rng As Range

Set ws = ThisWorkbook.Sheets("Master Data Set")
Set wsDest = Workbooks.Open("D:\My Documents\Excel Spreadsheets\TEST.xlsx")
xrow = 4
ilastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
initial = "CWS"
j = 1

For i = xrow To ilastrow
    If ws.Cells(i, 1).text = initial Then
      ws.Range("E" & i & ":J" & i).Copy Destination:=wsDest.Sheets(initial).Range(Cells(j, 1), Cells(j, 6))
      j = j + 1
    End If
Next i

End Sub