Question

我正在尝试自动控制查找和复制并控制查找和复制，粘贴到新工作表（工作表2）并从原始工作表（工作表1）中删除数据。

我有40-50个实体名称（如AIUH，ASC，ABB＆amp; BSS等），我找到并复制将子实体详细信息粘贴到sheet2并从sheet1中删除行。将有大约3000行来查看这些40-50个实体的详细信息，并且不会有固定数量的实体和子实体细节。

在这个例子中，我应该在列c中搜索AIUH（C4）然后移动到B4并复制值并使用B3值在活动单元格之后搜索并将行从B4复制到一个单元格然后复制到下一个与B3匹配的值直到B6，此值为3。（在此搜索条件中，如果B4及以上是升序，则只应复制行，否则应跳过复制。）

在AIUH的这个例子中，B4值为3，B5，B6和B5为B5，B6和B5。 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来引用您要执行操作的单元格和单元格区域。这些不是实现范围参考的可靠方法;特别是当涉及行（或单元格或列）删除时，因为单元格中的移位倾向于重新定位当前选择。

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个标头值的变量数组。应用过滤器后，将检查每个可见行下方的单元格是否可见。这些值将被传输，然后保留行Union method以便删除。

¹_{有关远离依赖选择和激活以实现目标的更多方法，请参阅How to avoid using Select in Excel VBA macros。}

查找数据并移至上一个单元格，然后使用活动单元格值重新查找

1 个答案: