条件に基づいてあるブックから別のブックに特定の範囲をコピーしてください

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 

ありがとうございました。明らかにできるものがあれば教えてください。今のところ、私は作成したテストブックに各ケースマネージャの名前を付けたワークシートを貼り付けようとしています。

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

単一の値を1回だけ検索する場合は、Do Loopを避けることにします。同じ値を2回以上検索するように変更する必要がある場合は、ここに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状態でコピーする必要がある複数のレコードがあること。

配列内のデータを収集し、そのデータを1回の操作で範囲に書き込むようにコードを変更しました。

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