Find data and move to prior cell and find again using active cell value

Question

I am trying to automate control find and copy and control find and copy, paste to new sheet (sheet2) and delete data from original sheet (sheet1).

I have 40-50 entity names (like AIUH, ASC, ABB & BSS.. etc) which I find and copy paste the sub entity details to sheet2 and delete the rows from sheet1. There will be around 3000 rows to look at these 40-50 entities details and there will not be a fixed number of entities and sub entities details.

In this example I should search in column c with AIUH (C4) then move to B4 and copy the value and search using after active cell using B3 value and copy the Rows from B4 to one cell before to next value matching to B3 value of 3 in this until B6. (In this search conditions apply if the B4 and above is ascending the only it should copy the rows otherwise it should skip copying it.)

In this example for AIUH we have B4 value is 3 and B5, B6 & B7 value is increasing 4, 5 which we need to cut and paste to sheet2 from sheet1 and similarly we need to search and cut and paste to sheet2. If B5 value is 3 or less than 3 then it should not copy paste the data to 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

Here is the code which I was able to get for few steps:

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

Here not able to use the active cell value to find and copy paste the data for all the entities to sheet2.

Once this is done I should take a count of each entities sub entity details like AIUH has total 3 entities like for all I should take count.

score 0 · Accepted Answer · edited May 23 '17 at 12:04

You are going to want to get away from relying on .Select and .Activate to reference cells and cell ranges that you want to perform actions¹ on. These are simply not reliable methods of achieving a range reference; especially so when row (or cell or column) deletion is involved as the shift in cells tends to relocate the current selection.

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

I've used the AutoFilter method with a variant array holding all of the 40-50 Header values. After the filter has been applied, the cells below each visible row is examined whether they are visible or not. The values are transferred across and the rows are retained with the Union method for deletion afterwards.

¹ _{See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.}

Thank you Expert Jeeped :) i thought filters doesnt work here but it worked superbly and now i just need to find a way to count the entities under each head as these should be reported in dashboard's with count for each entity currently having number of entities...If possible please help me out or guide me towards it. Thanks lot for this and have great weekend!! — suresh7860, Jan 31 '16 at 07:42
Thanks for guiding not to use Activate & select and i was thinking if we use multiple activate and select in single check it might not work but will try to reduce it fully from now on.. thanks expert Jeeped :) — suresh7860, Jan 31 '16 at 07:46
Can we use contains in the filters as sometimes we might have space in the beginning or at the end or even some addtional text also? but i am trying here with vFLTRs = Array("*BBS*", "*ABB*", "*ASC*", "*AIUH*", "*YYY*", "*ZZZ*") but its not working, would you please tell me whether i should define to use contains in this auto filter array? @Expert Jeeped — suresh7860, Jan 31 '16 at 08:12
I've added the count to the target worksheet; it had already been stored in a var called `cnt`. If you need to add wildcards, you should take a look at [this question](http://stackoverflow.com/questions/16602872/set-auto-filtering-multiple-wildcards). If that doesn't cover the topic adequately, get started on it and post another question detailing your progress and any problems(s) you run into. Changing the scope of a question substantially is generally considered bad etiquette as it leads to [Russian Doll Questions](http://meta.stackexchange.com/questions/188625). — , Jan 31 '16 at 08:15
@Jeeped- there has been an addendum, to this question the op has started a new one, wants to use contains in the filter, I thought of one idea the thread is located here. http://stackoverflow.com/questions/35112041/find-data-and-move-to-prior-cell-and-find-again-using-active-cell-value-proble/35114129?noredirect=1#comment57955052_35114129 — Davesexcel, Feb 01 '16 at 13:03
@Davesexcel - yes, I was hoping the OP would have made more of an attempt according to [the link](http://stackoverflow.com/questions/16602872/set-auto-filtering-multiple-wildcards) I provided above but sadly, that does not appear to be the case. — , Feb 01 '16 at 13:57

Find data and move to prior cell and find again using active cell value

1 Answers1

Linked