範囲をVBAで配列に挿入して反復する

Question

VBAに関するいくつかの問題に直面しています。私が達成しようとしていることを説明しましょう。 1つのワークブックに2枚あります。それらは "Sheet1"と "Sheet2"というラベルが付けられています。

"Sheet1"には、100行と100列があります。列Aには、例えば：SUBJ001が一杯になります。 「Sheet2」には列Aが1つしかなく、行の範囲があります。例：「SUBJ003、SUBJ033、SUBJ45」私が達成しようとしているのは、マウスを使って、 "Sheet2"の列Aを強調表示し、各セルを列Aのセルと比較することです。一致するものがあれば、行全体がコピーされ、マクロが同じブックに作成する新しいシート。 ！=編曲（I）は、...おかげ

Sub Copy_To_Another_Sheet_1() 
Dim FirstAddress As String 
Dim MyArr As Variant 
Dim Rng As Range 
Dim Rcount As Long 
Dim I As Long 
Dim NewSh As Worksheet 

With Application 
    .ScreenUpdating = False 
    .EnableEvents = False 
End With 

Set Rng = Application.InputBox("Select target range with the mouse", Type:=8) 

MyArr = Rng 

Set NewSh = Worksheets.Add 

With Sheets("Sheet1").Range("A:A") 

    Rcount = 0 

    For I = LBound(MyArr) To UBound(MyArr) 

     Set Rng = .Find(What:=MyArr(I), _ 
         After:=.Cells(.Cells.Count), _ 
         LookIn:=xlFormulas, _ 
         LookAt:=xlPart, _ 
         SearchOrder:=xlByRows, _ 
         SearchDirection:=xlNext, _ 
         MatchCase:=False) 
     If Not Rng Is Nothing Then 
      FirstAddress = Rng.Address 
      Do 
       Rcount = Rcount + 1 

       Rng.EntireRow.Copy NewSh.Range("A" & Rcount) 

       ' Use this if you only want to copy the value 
       ' NewSh.Range("A" & Rcount).Value = Rng.Value 

       Set Rng = .FindNext(Rng) 
      Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress 
     End If 
    Next I 
End With 

With Application 
    .ScreenUpdating = True 
    .EnableEvents = True 
End With 

End Subの

Answer 1

MyArr = RngがするMyArrを設定されています。しかし、私は何を設定し、RNG = .Find（の範囲エラーのうちに経験しています最初のランクがRngの行に対応し、第二ランクがRngの列に対応して2次元配列。

だけRngで一つの列を持っていると仮定すると、あなたのFind文はその最初の値を参照する必要がありますを使用して列、つまり

Set Rng = .Find(What:=MyArr(I, 1), _ 
        After:=.Cells(.Cells.Count), _ 
        LookIn:=xlFormulas, _ 
        LookAt:=xlPart, _ 
        SearchOrder:=xlByRows, _ 
        SearchDirection:=xlNext, _ 
        MatchCase:=False)