Macro to always select the first option available in filtered column

thachad098 · Aug 11, 2022

Hello everyone, I hit a roadblock when I created a macro and I am hoping someone with extensive macro/VBA experience would be able to help me out.

What I am trying to do is to add a filter in column A, select the first option, do a bunch of processing on the data, copy it to a FINAL sheet and delete that data so the top-most option on the filter will be the next item to be processed.

The challenge that I am experiencing is on the filter portion. Instead of recording checkbox1, its recording the actual column value selected. For simplicity, I have created a simple macro of this filter/delete process. This has column A named TEST with values 1,2,3,4,5. As you can see, the criteria reflects the value that I selected on the filter.

Sub FILTER_AND_DELETE()
'
' FILTER_AND_DELETE Macro
'

'
Columns("A:A").Select
Selection.AutoFilter
Range("A2").Select
ActiveSheet.Range("$A$1:$A$6").AutoFilter Field:=1, Criteria1:="1"
Rows("2:2").Select
Selection.Delete Shift:=xlUp
Columns("A:A").Select
Selection.AutoFilter
Columns("A:A").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$A$6").AutoFilter Field:=1, Criteria1:="2"
Rows("2:2").Select
Selection.Delete Shift:=xlUp
Columns("A:A").Select
Selection.AutoFilter
Columns("A:A").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$A$6").AutoFilter Field:=1, Criteria1:="3"
Rows("2:2").Select
Selection.Delete Shift:=xlUp
Columns("A:A").Select
Selection.AutoFilter
Columns("A:A").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$A$6").AutoFilter Field:=1, Criteria1:="4"
Rows("2:2").Select
Selection.Delete Shift:=xlUp
Columns("A:A").Select
Selection.AutoFilter
Columns("A:A").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$A$6").AutoFilter Field:=1, Criteria1:="<>"
Rows("2:2").Select
Selection.Delete Shift:=xlUp
Columns("A:A").Select
Selection.AutoFilter
Columns("A:A").Select
Selection.AutoFilter
End Sub

Any help that you can provide on this is highly appreciated.

Chad

HaHoBe · Aug 11, 2022

Hi Chad,

test for code was made on this sample:

MrE macro-to-always-select-the-first-option-available-in-filtered-column.1213315 220811.xlsm

A

B

1

Numbers

Order

2

1

alpha

3

2

beta

4

3

charlie

5

4

delta

6

5

echo

7

6

foxtrott

Data

In order to make SpecialCells work as expected it´s necessary that at least 2 cells should be visible when filtered.

Code used based on an old thread from this forum:

Code:

Sub Chad()
'https://www.mrexcel.com/board/threads/macro-to-always-select-the-first-option-available-in-filtered-column.1213315/
'code based on https://www.mrexcel.com/board/threads/vba-to-advance-to-next-unique-criteria-in-autofilter-list.1081461/post-5195923
'thanks Fluff
 
  Dim rngCell As Range
  Dim lngCounter As Long
  Dim objDic As Object
 
  Const cstrSheetData As String = "Data"        'change to suit
  Const cstrSheetTarget As String = "Collect"   'change to suit
 
  With Sheets(cstrSheetData)
    If .AutoFilterMode Then .Range("A1").AutoFilter
    Set objDic = CreateObject("scripting.dictionary")
    For Each rngCell In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
      objDic.Item(rngCell.Value) = Empty
    Next rngCell
    For lngCounter = 0 To objDic.Count - 1
      .Range("A1").CurrentRegion.AutoFilter 1, objDic.Keys()(lngCounter)
        With .Range("A2", .Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
          .Copy Sheets("Collect").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
          .EntireRow.Delete
        End With
    Next lngCounter
    If .AutoFilterMode Then .Range("A1").AutoFilter
  End With
End Sub

Please check on a sample file with Sheets Data and Collect or adjust the names of the worksheets to suit.

Ciao,
Holger

thachad098 · Aug 11, 2022

HaHoBe said:
Hi Chad,

test for code was made on this sample:

MrE macro-to-always-select-the-first-option-available-in-filtered-column.1213315 220811.xlsm
A B
1 Numbers Order
2 1 alpha
3 2 beta
4 3 charlie
5 4 delta
6 5 echo
7 6 foxtrott
Data

In order to make SpecialCells work as expected it´s necessary that at least 2 cells should be visible when filtered.

Code used based on an old thread from this forum:

Code:

Sub Chad() 'https://www.mrexcel.com/board/threads/macro-to-always-select-the-first-option-available-in-filtered-column.1213315/ 'code based on https://www.mrexcel.com/board/threads/vba-to-advance-to-next-unique-criteria-in-autofilter-list.1081461/post-5195923 'thanks Fluff Dim rngCell As Range Dim lngCounter As Long Dim objDic As Object Const cstrSheetData As String = "Data" 'change to suit Const cstrSheetTarget As String = "Collect" 'change to suit With Sheets(cstrSheetData) If .AutoFilterMode Then .Range("A1").AutoFilter Set objDic = CreateObject("scripting.dictionary") For Each rngCell In .Range("A2", .Range("A" & .Rows.Count).End(xlUp)) objDic.Item(rngCell.Value) = Empty Next rngCell For lngCounter = 0 To objDic.Count - 1 .Range("A1").CurrentRegion.AutoFilter 1, objDic.Keys()(lngCounter) With .Range("A2", .Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible) .Copy Sheets("Collect").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) .EntireRow.Delete End With Next lngCounter If .AutoFilterMode Then .Range("A1").AutoFilter End With End Sub

Please check on a sample file with Sheets Data and Collect or adjust the names of the worksheets to suit.

Ciao,
Holger

Hello Holger,

Thank you for taking the time for looking into my inquiry. What you have provided does not meet what I need, but that is on me not providing the whole picture. Kindly see attached image on how the data looks and how it should be transformed. I have 3 sheets; DATA where the initial records will be dumped, STAGING where each record that matches the filter will be processed and COLLECT to consolidate the final output. I have also provided the updated script below of the whole process on how I did it, but for my requirement the Criteria1 should not be fixed value as the records extracted what will use this macro varies.

I also recorded up to 10 lines to anticipate records extracted that exceed my current values.

Sub FILTER_MACRO()
'
' FILTER_MACRO Macro
'

'
Cells.Select
Selection.AutoFilter
Range("A1").Select
ActiveSheet.Range("$A$1:$L$20").AutoFilter Field:=1, Criteria1:="1"
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Staging").Select
Range("A1").Select
ActiveSheet.Paste
Range("B2").Select
Application.CutCopyMode = False
Selection.Cut
Range("C1").Select
ActiveSheet.Paste
Range("B3").Select
Selection.Cut
Range("D1").Select
ActiveSheet.Paste
Range("B4").Select
Selection.Cut
Range("E1").Select
ActiveSheet.Paste
Range("B5").Select
Selection.Cut
Range("F1").Select
ActiveSheet.Paste
Range("B6").Select
Selection.Cut
Range("G1").Select
ActiveSheet.Paste
Range("B7").Select
Selection.Cut
Range("H1").Select
ActiveSheet.Paste
Range("B8").Select
Selection.Cut
Range("I1").Select
ActiveSheet.Paste
Range("B9").Select
Selection.Cut
Range("J1").Select
ActiveSheet.Paste
Range("B10").Select
Selection.Cut
Range("K1").Select
ActiveSheet.Paste
Rows("1:1").Select
Selection.Cut
Sheets("Collect").Select
Rows("2:2").Select
Selection.Insert Shift:=xlDown
Sheets("Staging").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Sheets("Data").Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
Cells.Select
Selection.AutoFilter
Selection.AutoFilter
Range("A1").Select
ActiveSheet.Range("$A$1:$L$20").AutoFilter Field:=1, Criteria1:="2"
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Application.CutCopyMode = False
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Sheets("Staging").Select
ActiveSheet.Paste
Range("B2").Select
Application.CutCopyMode = False
Selection.Cut
Range("C1").Select
ActiveSheet.Paste
Range("B3").Select
Selection.Cut
Range("D1").Select
ActiveSheet.Paste
Range("B4").Select
Selection.Cut
Range("E1").Select
ActiveSheet.Paste
Range("B5").Select
Selection.Cut
Range("F1").Select
ActiveSheet.Paste
Range("B6").Select
Selection.Cut
Range("G1").Select
ActiveSheet.Paste
Range("B7").Select
Selection.Cut
Range("H1").Select
ActiveSheet.Paste
Range("B8").Select
Selection.Cut
Range("I1").Select
ActiveSheet.Paste
Range("B9").Select
Selection.Cut
Range("J1").Select
ActiveSheet.Paste
Range("B10").Select
Selection.Cut
Range("K1").Select
ActiveSheet.Paste
Rows("1:1").Select
Selection.Cut
Sheets("Collect").Select
Selection.Insert Shift:=xlDown
Sheets("Staging").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Sheets("Data").Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
Cells.Select
Selection.AutoFilter
Selection.AutoFilter
Range("A1").Select
ActiveSheet.Range("$A$1:$L$20").AutoFilter Field:=1, Criteria1:="<>"
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Staging").Select
Range("A1").Select
ActiveSheet.Paste
Range("B2").Select
Application.CutCopyMode = False
Selection.Cut
Range("C1").Select
ActiveSheet.Paste
Range("B3").Select
Selection.Cut
Range("D1").Select
ActiveSheet.Paste
Range("B4").Select
Selection.Cut
Range("E1").Select
ActiveSheet.Paste
Range("B5").Select
Selection.Cut
Range("F1").Select
ActiveSheet.Paste
Range("B6").Select
Selection.Cut
Range("G1").Select
ActiveSheet.Paste
Range("B7").Select
Selection.Cut
Range("H1").Select
ActiveSheet.Paste
Range("B8").Select
Selection.Cut
Range("I1").Select
ActiveSheet.Paste
Range("B9").Select
Selection.Cut
Range("J1").Select
ActiveSheet.Paste
Range("B10").Select
Selection.Cut
Range("K1").Select
ActiveSheet.Paste
Rows("1:1").Select
Selection.Cut
Sheets("Collect").Select
Selection.Insert Shift:=xlDown
Sheets("Staging").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Sheets("Data").Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
Cells.Select
Selection.AutoFilter
Selection.AutoFilter
Range("A1").Select
End Sub

Any input that you can provide on this is highly appreciated.

HaHoBe · Aug 12, 2022

Hi Chad,

there are two things I would like to mention: if you post code please wrap it in [ code ]Your code[ /code ] without blanks inside the square brackets or mark the code and hit the VBA symbol at the top of the rply window. This would enable anybody to get the whole code with one single click to the clipboard (with all white spaces from the original code) and limit the space the code takes on viewing the thread/post. Second is please give a description of how the original data looks like and what you want to do. If I get a good descritption of what you want it´s like a plan of what to code for me.

From all I see you want to copy and Paste/Transpose. Based on your picture this is what you have:

MrE macro-to-always-select-the-first-option-available-in-filtered-column.1213315 220811.xlsm

A

B

C

D

E

F

G

H

I

J

K

L

M

N

1

KEY

Val1

Val2

Val3

Val4

Val5

Val6

Val7

Val8

Val9

Val10

DATA

Before

2

1

q

DATA

Before

3

1

w

DATA

Before

4

1

e

DATA

Before

5

1

r

DATA

Before

6

1

t

DATA

Before

7

1

y

DATA

Before

8

2

a

DATA

Before

9

2

s

DATA

Before

10

2

d

DATA

Before

11

2

f

DATA

Before

12

2

g

DATA

Before

13

2

h

DATA

Before

14

2

j

DATA

Before

15

2

k

DATA

Before

16

3

z

DATA

Before

17

3

x

DATA

Before

18

3

c

DATA

Before

19

20

KEY

Val1

Val2

Val3

Val4

Val5

Val6

Val7

Val8

Val9

Val10

STAGING

Before

Tabelle2

And this is what you want to get:

MrE macro-to-always-select-the-first-option-available-in-filtered-column.1213315 220811.xlsm

A

B

C

D

E

F

G

H

I

J

K

L

M

N

1

KEY

Val1

Val2

Val3

Val4

Val5

Val6

Val7

Val8

Val9

Val10

DATA

After

2

3

KEY

Val1

Val2

Val3

Val4

Val5

Val6

Val7

Val8

Val9

Val10

STAGING

After

4

3

z

x

c

STAGING

After

5

2

a

s

d

f

g

h

j

k

STAGING

After

6

1

q

w

e

r

t

y

STAGING

After

Tabelle3

Code used:

Code:

Sub Chad_Scenario2_Transpose()
'https://www.mrexcel.com/board/threads/macro-to-always-select-the-first-option-available-in-filtered-column.1213315/
  
  Dim rngCell As Range
  Dim lngCounter As Long
  Dim objDic As Object
  Dim wsData As Worksheet
  Dim wsStaging As Worksheet
  
  Set wsData = ThisWorkbook.Sheets("DATA")
  Set wsStaging = ThisWorkbook.Sheets("STAGING")
  
  With wsData
    If .AutoFilterMode Then .Range("A1").AutoFilter
    Set objDic = CreateObject("scripting.dictionary")
    For Each rngCell In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
      objDic.Item(rngCell.Value) = Empty
    Next rngCell
    For lngCounter = 0 To objDic.Count - 1
      .Range("A1").CurrentRegion.AutoFilter 1, objDic.Keys()(lngCounter)
        With .Range("B2", .Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
          wsStaging.Range("A2").EntireRow.Insert
          .Copy
          wsStaging.Range("B2").PasteSpecial Paste:=xlPasteAll, _
                                              Operation:=xlNone, _
                                              SkipBlanks:=False, _
                                              Transpose:=True
          wsStaging.Range("A2").Value = objDic.Keys()(lngCounter)
          .EntireRow.Delete
        End With
    Next lngCounter
    If .AutoFilterMode Then .Range("A1").AutoFilter
  End With

  Set wsStaging = Nothing
  Set wsData = Nothing

End Sub

I changed the original data to look like

MrE macro-to-always-select-the-first-option-available-in-filtered-column.1213315 220811.xlsm

A

B

26

KEY

Val1

27

2

a

28

3

c

29

2

d

30

1

e

31

2

f

32

2

g

33

2

h

34

2

j

35

2

k

36

1

q

37

1

r

38

2

s

39

1

t

40

1

w

41

3

x

42

1

y

43

3

z

Tabelle1

and got the same result from the code.

Ciao,
Holger

thachad098 · Aug 15, 2022

HaHoBe said:
Hi Chad,

there are two things I would like to mention: if you post code please wrap it in [ code ]Your code[ /code ] without blanks inside the square brackets or mark the code and hit the VBA symbol at the top of the rply window. This would enable anybody to get the whole code with one single click to the clipboard (with all white spaces from the original code) and limit the space the code takes on viewing the thread/post. Second is please give a description of how the original data looks like and what you want to do. If I get a good descritption of what you want it´s like a plan of what to code for me.

From all I see you want to copy and Paste/Transpose. Based on your picture this is what you have:

MrE macro-to-always-select-the-first-option-available-in-filtered-column.1213315 220811.xlsm
A B C D E F G H I J K L M N
1 KEY Val1 Val2 Val3 Val4 Val5 Val6 Val7 Val8 Val9 Val10 DATA Before
2 1 q DATA Before
3 1 w DATA Before
4 1 e DATA Before
5 1 r DATA Before
6 1 t DATA Before
7 1 y DATA Before
8 2 a DATA Before
9 2 s DATA Before
10 2 d DATA Before
11 2 f DATA Before
12 2 g DATA Before
13 2 h DATA Before
14 2 j DATA Before
15 2 k DATA Before
16 3 z DATA Before
17 3 x DATA Before
18 3 c DATA Before
19
20 KEY Val1 Val2 Val3 Val4 Val5 Val6 Val7 Val8 Val9 Val10 STAGING Before
Tabelle2

And this is what you want to get:

MrE macro-to-always-select-the-first-option-available-in-filtered-column.1213315 220811.xlsm
A B C D E F G H I J K L M N
1 KEY Val1 Val2 Val3 Val4 Val5 Val6 Val7 Val8 Val9 Val10 DATA After
2
3 KEY Val1 Val2 Val3 Val4 Val5 Val6 Val7 Val8 Val9 Val10 STAGING After
4 3 z x c STAGING After
5 2 a s d f g h j k STAGING After
6 1 q w e r t y STAGING After
Tabelle3

Code used:

Code:

Sub Chad_Scenario2_Transpose() 'https://www.mrexcel.com/board/threads/macro-to-always-select-the-first-option-available-in-filtered-column.1213315/ Dim rngCell As Range Dim lngCounter As Long Dim objDic As Object Dim wsData As Worksheet Dim wsStaging As Worksheet Set wsData = ThisWorkbook.Sheets("DATA") Set wsStaging = ThisWorkbook.Sheets("STAGING") With wsData If .AutoFilterMode Then .Range("A1").AutoFilter Set objDic = CreateObject("scripting.dictionary") For Each rngCell In .Range("A2", .Range("A" & .Rows.Count).End(xlUp)) objDic.Item(rngCell.Value) = Empty Next rngCell For lngCounter = 0 To objDic.Count - 1 .Range("A1").CurrentRegion.AutoFilter 1, objDic.Keys()(lngCounter) With .Range("B2", .Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible) wsStaging.Range("A2").EntireRow.Insert .Copy wsStaging.Range("B2").PasteSpecial Paste:=xlPasteAll, _ Operation:=xlNone, _ SkipBlanks:=False, _ Transpose:=True wsStaging.Range("A2").Value = objDic.Keys()(lngCounter) .EntireRow.Delete End With Next lngCounter If .AutoFilterMode Then .Range("A1").AutoFilter End With Set wsStaging = Nothing Set wsData = Nothing End Sub

I changed the original data to look like

MrE macro-to-always-select-the-first-option-available-in-filtered-column.1213315 220811.xlsm
A B
26 KEY Val1
27 2 a
28 3 c
29 2 d
30 1 e
31 2 f
32 2 g
33 2 h
34 2 j
35 2 k
36 1 q
37 1 r
38 2 s
39 1 t
40 1 w
41 3 x
42 1 y
43 3 z
Tabelle1

and got the same result from the code.

Ciao,
Holger

Hello Holger,

Hope you had a great weekend. Apologies for not using the UBB codes, will utilize those moving forward.

Thank you very much for the latest code that you have provided. That is exactly what I was hoping to achieve. You are super awesome!

HaHoBe · Aug 15, 2022

Hi Chad,

glad that I could help on this topic and thanks for the feedback.

Ciao,
Holger

Macro to always select the first option available in filtered column

thachad098

New Member

Excel Facts

HaHoBe

Well-known Member

thachad098

New Member

Attachments

HaHoBe

Well-known Member

thachad098

New Member

HaHoBe

Well-known Member

Similar threads

Forum statistics

Share this page

Macro to always select the first option available in filtered column

thachad098

New Member

Excel Facts

HaHoBe

Well-known Member

thachad098

New Member

Attachments

HaHoBe

Well-known Member

thachad098

New Member

HaHoBe

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock