Copy Specific Range from one workbook to another based on condition - vba

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