根据条件将特定范围从一个工作簿复制到另一个工作簿

Question

感谢您花时间阅读此内容。我有一个主联系人工作簿，其中包含需要跟进呼叫的人员列表。在本工作手册的第一栏中列出了被分配后续电话的人的姓名缩写（例如：CWS）。我想要的是一个公式，它将扫描第一列中的所有单元格以获得一组首字母，然后将列E至J中的数据复制到专门分配给该案例管理器的新工作簿中。下面的代码只是一个框架，但它足以做一个小测试。我在10年内没有触及过VBA，所以我敢肯定它还不够完美

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 

非常感谢您的帮助。请让我知道，如果有什么我可以澄清。现在，我只是试图粘贴到我创建的测试工作簿上，并填写了每个Case Manager后命名的工作表。

Answer 1

收拾了一些东西。你非常亲密，努力工作很长时间。

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 

Answer 2

如果您一次只搜索一个值，我会避免Do Loop。如果您需要修改它以搜索相同的值，那么您可以在这里找到使用Range().FindNext的一些很好的示例：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：在注释中，有需要复制多个记录的OP状态。

我修改了代码来收集数组中的数据并在单个操作中将数据写入范围。

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