VBA code to extract unique data across multiple sheets and multiple columns

mereslav

New Member
Joined
Feb 23, 2022
Messages
2
Office Version
  1. 2016
Platform
  1. Windows
Hi everyone,

I'm searching the web but I only found one code that kind of works but I need to make it more complex.
Let me explain.
My issue is that I have an Excel sheet with multiple worksheets, which all contain the same kind of information but are copied weekly by me. So every week, I will add one more worksheet.
Each worksheet contains a list of workers we have with their ID number, clock in and clock out and also start date, area of work etc.. basically the data spans from column A to column G and starts in row 7 and goes to infinity as every week there's a different number of workers as some are hired, and some resign.
In Sheet1, I want to have a button named Update Worker List (already have that :D) that will run this VBA code when I click it, and put a new updated list of all the workers we have in the latest worksheet ( I understand it will include even those that have resigned, but that is okay) in columns A to G, starting in row 3.

I have this at the moment but it only extracts column A.

Don't get confused, WC240122 means Week Commencing 24/01/22...

'' 'Example of how to use scripting dictionary to list unique values
''' Assumes data is in column A of "Sheet1", "Sheet2", "Sheet3", "Sheet4", & "Sheet5"
''' Results are written to "Sheet6"
'
Sub GetUnique()
Dim Rng As Range, R As Range
Dim SD As Object
Dim KeyStr As String, RefStr As String
Dim WB As Workbook
Dim WS As Worksheet
Dim I As Long

Set WB = ActiveWorkbook
Set WS = ActiveSheet

Set SD = CreateObject("Scripting.dictionary")
RefStr = "" 'Value stored in dictionary

For Each WS In WB.Worksheets
Select Case WS.Name
Case "WC170122", "WC240122", "WC310122", "WC070222", "WC140222"
Set Rng = WS.Range("A7:A" & WS.Range("A" & WS.Rows.Count).End(xlUp).Row)
For Each R In Rng
KeyStr = R.Value 'Search Key stored in dictionary
If Not SD.Exists(KeyStr) Then 'Unique key value, not already in the dictionary
SD.Add KeyStr, RefStr
End If
Next R
End Select
Next WS

Set WS = WB.Worksheets("Sheet1")
WS.Range("A3:G300").ClearContents

With WS.Range("A3")
For I = 0 To SD.Count - 1
.Offset(I).Value = SD.keys()(I)
Next I
End With
End Sub


Thank you very much for helping.
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
Sorry for the format, here it is correctly


VBA Code:
'' 'Example of how to use scripting dictionary to list unique values
''' Assumes data is in column A of "Sheet1", "Sheet2", "Sheet3", "Sheet4", & "Sheet5"
''' Results are written to "Sheet6"
'
Sub GetUnique()
    Dim Rng As Range, R As Range
    Dim SD As Object
    Dim KeyStr As String, RefStr As String
    Dim WB As Workbook
    Dim WS As Worksheet
    Dim I As Long

    Set WB = ActiveWorkbook
    Set WS = ActiveSheet

    Set SD = CreateObject("Scripting.dictionary")
    RefStr = ""    'Value stored in dictionary

    For Each WS In WB.Worksheets
        Select Case WS.Name
        Case "WC170122", "WC240122", "WC310122", "WC070222", "WC140222"
            Set Rng = WS.Range("A7:A" & WS.Range("A" & WS.Rows.Count).End(xlUp).Row)
            For Each R In Rng
                KeyStr = R.Value    'Search Key stored in dictionary
                If Not SD.Exists(KeyStr) Then    'Unique key value, not already in the dictionary
                    SD.Add KeyStr, RefStr
                End If
            Next R
        End Select
    Next WS

    Set WS = WB.Worksheets("Sheet1")
    WS.Range("A3:G300").ClearContents

    With WS.Range("A3")
        For I = 0 To SD.Count - 1
            .Offset(I).Value = SD.keys()(I)
        Next I
    End With
End Sub
 
Upvote 0

Forum statistics

Threads
1,224,813
Messages
6,181,112
Members
453,021
Latest member
Justyna P

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top