根據條件將特定範圍從一個工作簿複製到另一個工作簿

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