PICK OUT/EXTRACT column header "COMMON" IN ALL 5 SHEETS

[panyagak]

Hi Excel gurus

Please help.

My 4 worksheets are named: Wk1, Wk2, Wk3 &
Wk4, Wk5. In the 5 sheets, columns A (Date) and B ( Subject name) are similar. I need a vba code to
pick out only"Subject names" that ARE COMMON in ALL THE 5 sheets and paste them in a new sheet, "New All".

Am tired of copy, paste & sort more than 20,000 rows!!

HELP!!

 

[panyagak]

Hi Gallen.

This is the explanation from you for the MAGICAL code above:

"The code I provided loops through all subject names in Wk1. It then check Wk2 - Wk5 to see if that name exists in that sheet anywhere. If it is found in all sheets it copies the data from Wk1 to 'New All'"

What if I add several Wks eg. Wk6,Wk7,Wk8 next to Wk5? Will the code still apply.

Thanks & regards

 

[panyagak]

Merry Xmas to ALL MREXCEL USERS.

Thank you Gallen AGAIN for this Super-code in #6

I would like to introduce another condition, which is Column Z, which contains filtered Integers so that besides Subject Names alone, we now have to match Subject Names and Z Column values.( Any Header title can do).

Thanks

 

[panyagak]

HI Mrexcelians AGAIN!!!

REF #06 .

THis code has been and is wonderful in my data analysis; THOUGH after increasing the number of rows to over 100,000 IN ONLY 2 WORKSHEETS, its gets "TOO SLOW"!!

ANY WAY TO TWERK THE CODE TO SPEED UP THE LOOPING, PLEASE?

Regards
PATRICK

 

[gallen]

HI Mrexcelians AGAIN!!!

REF #06 .

THis code has been and is wonderful in my data analysis; THOUGH after increasing the number of rows to over 100,000 IN ONLY 2 WORKSHEETS, its gets "TOO SLOW"!!

ANY WAY TO TWERK THE CODE TO SPEED UP THE LOOPING, PLEASE?

Regards
PATRICK

Hello. Try this. Amendments in red.

Sub FindAll()
    Dim rNames As Range, Name As Range, rFound As Range
    Dim lr As Long 'Last row in Wk1
    Dim nr As Long ' next available row in New All
    Dim i As Integer 'counter for worksheets
    Dim sNamesSearched As String 'String to hold values of all names searched for
    
    
[COLOR=#ff0000]    On Error GoTo errHandle[/COLOR]
[COLOR=#ff0000]    Application.EnableEvents = False[/COLOR]
[COLOR=#ff0000]    Application.ScreenUpdating = False[/COLOR]
    
    lr = Worksheets("Wk1").Range("A" & Rows.Count).End(xlUp).Row
    nr = Worksheets("New All").Range("A" & Rows.Count).End(xlUp).Row + 1
    
    'Get Names range
    Set rNames = Worksheets("Wk1").Range("B2:B" & lr)
    
    For Each Name In rNames
        If InStr(1, sNamesSearched, Name) > 0 Then GoTo NextName 'if name already searched skip the name
        sNamesSearched = IIf(sNamesSearched = "", Name, sNamesSearched & "," & Name) 'record the name searched for
        For i = 2 To 5 'loop though worksheets 2 to 5
            'find an exact match
            Set rFound = Worksheets("Wk" & i).Range("B:B").Find(What:=Name, LookAt:=xlWhole)
            
            If rFound Is Nothing Then 'name not found so don't enter on New All
                GoTo NextName
            End If
        Next i
        'only get here if name is found in each sheet
        Name.EntireRow.Copy
        Worksheets("New All").Range("A" & nr).PasteSpecial xlPasteAll
        nr = nr + 1
        Application.CutCopyMode = False
NextName:
    Next Name
    
[COLOR=#ff0000]    Application.EnableEvents = True[/COLOR]
[COLOR=#ff0000]    Application.ScreenUpdating = True[/COLOR]
Exit Sub
    
[COLOR=#ff0000]errHandle:[/COLOR]
[COLOR=#ff0000]    MsgBox Err.Description, vbCritical, Err.Number[/COLOR]
[COLOR=#ff0000]    Application.EnableEvents = True[/COLOR]
[COLOR=#ff0000]    Application.ScreenUpdating = True[/COLOR]


    
End Sub

 

[panyagak]

Gallen.

Thank you for taking your time. I tried the code & worked well..........

Am yet to use 2 PCs to run concurrently the previous code & this new one with a Timer for measure speed.

Thanks a lot

 

[panyagak]

hi Mrexcel experts.

I would love to turn solutions #4 & #6 vba codes by Gallen into arrays to speed up the looping while limiting sheets Wk to only 2.

kindly check in

regards

Keep Safe

 

[panyagak]

Hello. Try this. Amendments in red.

Sub FindAll()
    Dim rNames As Range, Name As Range, rFound As Range
    Dim lr As Long 'Last row in Wk1
    Dim nr As Long ' next available row in New All
    Dim i As Integer 'counter for worksheets
    Dim sNamesSearched As String 'String to hold values of all names searched for
   
   
[COLOR=#ff0000]    On Error GoTo errHandle
    Application.EnableEvents = False
    Application.ScreenUpdating = False[/COLOR]
   
    lr = Worksheets("Wk1").Range("A" & Rows.Count).End(xlUp).Row
    nr = Worksheets("New All").Range("A" & Rows.Count).End(xlUp).Row + 1
   
    'Get Names range
    Set rNames = Worksheets("Wk1").Range("B2:B" & lr)
   
    For Each Name In rNames
        If InStr(1, sNamesSearched, Name) > 0 Then GoTo NextName 'if name already searched skip the name
        sNamesSearched = IIf(sNamesSearched = "", Name, sNamesSearched & "," & Name) 'record the name searched for
        For i = 2 To 5 'loop though worksheets 2 to 5
            'find an exact match
            Set rFound = Worksheets("Wk" & i).Range("B:B").Find(What:=Name, LookAt:=xlWhole)
           
            If rFound Is Nothing Then 'name not found so don't enter on New All
                GoTo NextName
            End If
        Next i
        'only get here if name is found in each sheet
        Name.EntireRow.Copy
        Worksheets("New All").Range("A" & nr).PasteSpecial xlPasteAll
        nr = nr + 1
        Application.CutCopyMode = False
NextName:
    Next Name
   
[COLOR=#ff0000]    Application.EnableEvents = True
    Application.ScreenUpdating = True[/COLOR]
Exit Sub
   
[COLOR=#ff0000]errHandle:
    MsgBox Err.Description, vbCritical, Err.Number
    Application.EnableEvents = True
    Application.ScreenUpdating = True[/COLOR]


   
End Sub

CORRECTED

Sub FindAll()
    Dim rNames As Range, Name As Range, rFound As Range
    Dim lr As Long 'Last row in Wk1
    Dim nr As Long ' next available row in New All
    Dim i As Integer 'counter for worksheets
    Dim sNamesSearched As String 'String to hold values of all names searched for
    
    
On Error GoTo errHandle
Application.EnableEvents = False
Application.ScreenUpdating = False
    
    lr = Worksheets("Wk1").Range("A" & Rows.Count).End(xlUp).Row
    nr = Worksheets("New All").Range("A" & Rows.Count).End(xlUp).Row + 1
    
    'Get Names range
    Set rNames = Worksheets("Wk1").Range("B2:B" & lr)
    
    For Each Name In rNames
        If InStr(1, sNamesSearched, Name) > 0 Then GoTo NextName 'if name already searched skip the name
        sNamesSearched = IIf(sNamesSearched = "", Name, sNamesSearched & "," & Name) 'record the name searched for
        For i = 2 To 2 'loop though worksheets 2 to 2
            'find an exact match
            Set rFound = Worksheets("Wk" & i).Range("B:B").Find(What:=Name, LookAt:=xlWhole)
            
            If rFound Is Nothing Then 'name not found so don't enter on New All
                GoTo NextName
            End If
        Next i
        'only get here if name is found in each sheet
        Name.EntireRow.Copy
        Worksheets("New All").Range("A" & nr).PasteSpecial xlPasteAll
        nr = nr + 1
        Application.CutCopyMode = False
NextName:
    Next Name
    
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub
    
errHandle:
MsgBox Err.Description, vbCritical, Err.Number
Application.EnableEvents = True
Application.ScreenUpdating = True


    
End Sub