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

感谢您抽时间阅读。 我有一个主联系人工作簿，其中包含需要跟进呼叫的人员列表。 在本工作手册的第一栏中列出了被分配后续电话的人的姓名缩写（例如：CWS）。 我想要的是一个公式，它将扫描第一列中的所有单元格以获取一组首字母，然后将数据从E到J列复制到专门分配给该个案pipe理器的新工作簿中。 下面的代码只是一个框架，但它足以做一个小testing运行。 我在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 

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

Answer 1

如果你只search一个值，我会避免Do Loop 。 如果你需要修改它以search相同的值，那么你会发现使用Range().FindNext一些很好的例子。FindNext在这里： Range.FindNext方法（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 

---

更新：OP在注释中声明有多个需要复制的logging。

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

 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

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

 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