查找數據並移動到之前的單元格，並使用活動單元格值再次找到

Question

我試圖自動控制查找並複製並控制查找和複製，粘貼到新工作表（工作表2）並從原始工作表（工作表1）中刪除數據。

我有40-50個實體名稱（如AIUH，ASC，ABB & BSS ..等），我找到並複製粘貼子實體的詳細信息到工作表2並從工作表1中刪除行。將會有大約3000行查看這些40-50個實體的細節，並且不會有固定數量的實體和子實體細節。

在這個例子中，我應該在列c中搜索AIUH（C4），然後移動到B4並複製值並在使用B3值後在活動單元格中搜索，並將B4中的行復制到一個單元格，然後再進行下一個值匹配B3中的B3值直到B6。 （在這個搜索條件下適用，如果B4和以上是隻有它應該複製的行，否則它應該跳過複製它。）

在這個AIUH的例子中，我們有B4值爲3和B5，B6 & B7值正在增加4,5，我們需要從sheet1剪切並粘貼到sheet2，同樣我們需要搜索並剪切並粘貼到sheet2。如果B5值爲3或小於3，則不應將數據粘貼到sheet2。

Index Level Header 
1 1  ADD 
2 2  WST 
3 3  AIUH 
4 4  AAC 
5 5  AAG 
6 3  ASC 
7 4  AIA 
8 3  AIS 
9 4  ABB 
10 5  APP 
11 5  RDS 
12 5  BBS 
13 6  SST 
14 6  PLI 
15 6  PPS 

這裏是我能得到幾步代碼：

Dim irange As Range 
Set irange = ActiveCell 
Sheets("Sheet1").Activate 
Columns("C:C").Select 

On Error Resume Next 
Selection.Find(What:="*AIUH*", After:=ActiveCell, LookIn:=xlFormulas, _ 
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ 
MatchCase:=False, SearchFormat:=False).Offset(0, -1).Activate 
ActiveCell.Interior.ColorIndex = 3 
ActiveCell.Copy 
Columns("A:A").Select 
Range("irange").Activate 

sheets("sheet1").Range("A:A").Cells.Find(("irange"), After:=ActiveCell, _ 
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _ 
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate 

這裏不能使用活動單元格值來查找和複製粘貼數據，所有的實體到Sheet2 。

一旦完成這個工作，我應該計算每個實體子實體的詳細信息，例如AIUH總共有3個實體，比如我應該計算的所有實體。

Answer 1

您將不想依靠.Select和.Activate來引用要執行操作1的單元格和單元格區域。這些不是實現範圍參考的可靠方法;特別是在涉及行（或單元格或列）刪除時，因爲單元格中的移動傾向於重新定位當前選擇。

Sub xferAscendingFiltered() 
    Dim cnt As Long, rHDR As Range, rDELs As Range, vFLTRs As Variant 

    'fill this array with your 40-50 Header values 
    vFLTRs = Array("AIS", "BBS", "AIUH", _ 
        "XXX", "YYY", "ZZZ") 

    With Worksheets("Sheet2") 
     If .AutoFilterMode Then .AutoFilterMode = False 
     With .Cells(1, 1).CurrentRegion 
      'filter on all the values in the array 
      .AutoFilter Field:=3, Criteria1:=vFLTRs, Operator:=xlFilterValues 

      'walk through the visible rows 
      With .Resize(.Rows.Count - 1, 1).Offset(0, 2) 
       Set rHDR = .Find(What:=Chr(42), After:=.Cells(1, 1), _ 
           SearchOrder:=xlByRows, SearchDirection:=xlNext) 
       'seed the rows to delete so Union can be used later 
       If rHDR.Row > 1 Then _ 
        Set rDELs = rHDR 

       Do While rHDR.Row > 1 

        cnt = 0 
        'increase cnt by both visible and hidden cells 
        Do 
         cnt = cnt + 1 
        Loop While rHDR.Offset(cnt, -1).Value2 > rHDR.Offset(cnt - 1, -1).Value2 And _ 
           Intersect(rHDR.Offset(cnt, 0), .SpecialCells(xlCellTypeVisible)) Is Nothing 

        'transfer the values and clear the original(s) 
        With .Cells(rHDR.Row, 1).Resize(cnt, 3).Offset(0, -2) 
         'transfer the values 
         Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(.Rows.Count, .Columns.Count) = .Value 
         'set teh count 
         Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1 - cnt, 3) = cnt 
         Set rDELs = Union(rDELs, .Cells) 
         rHDR.Clear 
        End With 

        'get next visible Header in column C 
        Set rHDR = .FindNext(After:=.Cells(1, 1)) 
       Loop 
       .AutoFilter 
      End With 

     End With 

     'remove the rows 
     rDELs.EntireRow.Delete 

    End With 

End Sub 

我已經使用了AutoFilter method與一個變體數組保存所有的40-50 Header值。過濾器應用後，檢查每個可見行下面的單元格是否可見。這些值將被傳輸，並且行將保留在Union method之後。

---

¹_{見How to avoid using Select in Excel VBA macros更多的方法從依靠選擇越來越遠，並激活，以實現自己的目標。}