Hi All,
Need your assistance for VBA code to get count of unique values in one particular column(column "A")
There are multiple files in a folder and for all the files the data is in column "A".
VBA to generate the unique values count in separate excel sheet along with file names.
Thank You.
Hi All,
Need your help for the requirement.
Then give more information and an example workbook.
Hi Roy,
Thanks for your kind response. Please find the details below.
1) There are multiple excel files in a folder.
2) In column "A" of every excel file details of employee IDs are there. Employee ID is a combination of alphabet and numeric value. The example is provided in the attached excel file.
3) The employee IDs of a few employees are repeated multiple times in the same column(column "A").
4) Need a VBA to provide the count of unique values in column "A" for all the excel files in the folder.
5) The count of unique values in column "A" of each excel file should be populated in a new excel sheet along with the file names.
6) Sample excel sheet is attached. The unique value count should be 6 for the file which is attached.
Your kind help is highly appreciated.
Thank you.
This will return how many unique entries occur in Sheet1.
Sub CountUniqueEntries()
Dim lRw As Long, rRng As Range, List As Object
lRw = Cells(Rows.Count, 1).End(xlUp).Row
Set List = CreateObject("Scripting.Dictionary")
With ActiveSheet
For Each rRng In .Range(.Cells(2, 1), .Cells(lRw, 1))
If Not List.Exists(rRng.Value) Then List.Add rRng.Value, Nothing
Next
End With
MsgBox "There are " & List.Count & " unique values in column A of " & ActiveSheet.Name
End SubDo you want the code to open each workbook in the folder and run the count?
Will each file have the data in the same Column and contain only one sheet?
Do you want to create a new workbook to contain the results?
Thank you for your message.
1. Yes the code should open the each workbook in the folder and run the count
2. Yes each file will have data in the same column and will have only one sheet.
3. Yes the results should populate in a new excel sheet along with the file names.
Thank you.
I haven't tested but post back if you have any problems.
Sub LoopFiles()
Dim oWb As Workbook, oNewBk As Workbook
Dim rRng As Range
Dim lRw As Long
Dim sFldr As String, sFilName As String
Dim fDialog As Object, List As Object
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
If fDialog.Show = -1 Then
sFldr = fDialog.SelectedItems(1)
Else: MsgBox "User cancelled selection"
Exit Sub
End If
''/// create new workbook
Set oNewBk = Workbooks.Add
ActiveWorkbook.SaveAs sFldr & Application.PathSeparator & "UniqueEntries.xlsx"
sFilName = Dir(sFldr & "\*.xls*")
Do While sFilName > ""
Set oWb = Workbooks.Open(sFldr & "\" & sFilName)
lRw = Cells(Rows.Count, 1).End(xlUp).Row
Set List = CreateObject("Scripting.Dictionary")
With ActiveSheet
For Each rRng In .Range(.Cells(2, 1), .Cells(lRw, 1))
If Not List.Exists(rRng.Value) Then List.Add rRng.Value, Nothing
Next
End With
With oNewBk.Sheets(1)
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Value = oWb.Name
.Cells(.Rows.Count, 2).End(xlUp).Offset(1).Value = List.Count
End With
oWb.Close SaveChanges:=False ''///Close opened worbook w/o saving, change as needed
Set List = Nothing
sFilName = Dir()
Loop
MsgBox "All files updated", vbInformation, "Success"
End SubEDIT: amended code to record count
Hi Roy,
Thanks for your kind help.
Tested the code, following are the observations.
1) After running the code one message box pops up. I have attached the screenshot of the same.
2) One excel file is created in the folder with the naming convention "UniqueEntries"
Request you to please assist.
Does that error occur when you first run the code?
The error occurred at the end(after running the code)
Try this
Sub LoopFiles()
Dim oWb As Workbook, oNewBk As Workbook
Dim rRng As Range
Dim lRw As Long
Dim sFldr As String, sFilName As String
Dim fDialog As Object, List As Object
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
If fDialog.Show = -1 Then
sFldr = fDialog.SelectedItems(1)
Else: MsgBox "User cancelled selection"
Exit Sub
End If
''/// create new workbook
Set oNewBk = Workbooks.Add
ActiveWorkbook.SaveAs sFldr & Application.PathSeparator & "UniqueEntries.xlsx"
Do While sFilName > "" And sFilName <> oNewBk.Name
Set oWb = Workbooks.Open(sFldr & "\" & sFilName)
lRw = Cells(Rows.Count, 1).End(xlUp).Row
Set List = CreateObject("Scripting.Dictionary")
With ActiveSheet
For Each rRng In .Range(.Cells(2, 1), .Cells(lRw, 1))
If Not List.Exists(rRng.Value) Then List.Add rRng.Value, Nothing
Next
End With
With oNewBk.Sheets(1)
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Value = oWb.Name
.Cells(.Rows.Count, 2).End(xlUp).Offset(1).Value = List.Count
End With
oWb.Close SaveChanges:=False ''///Close opened worbook w/o saving, change as needed
Set List = Nothing
sFilName = Dir()
Loop
MsgBox "All files updated", vbInformation, "Success"
End SubHi Roy,
After running the above code results are not populating. Only the excel sheet is created in the folder with the naming convention "UniqueEntries".
There is no data in the sheet.
What version of Office/Excel are you using?
if any of these:
Office/Excel for Microsoft 365, Office/Excel for Microsoft 365 for Mac, Office/Excel for the web, Office/Excel 2021, Office/Excel 2021 for Mac, Office/Excel for iPad, Office/Excel for iPhone, Office/Excel for Android tablets Excel for Android phones
Then the UNIQUE function can be used.
I missed a line of code when I was adapting it for you. Try this
Sub LoopFiles()
Dim oWb As Workbook, oNewBk As Workbook
Dim rRng As Range
Dim lRw As Long
Dim sFldr As String, sFilName As String
Dim fDialog As Object, List As Object
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
If fDialog.Show = -1 Then
sFldr = fDialog.SelectedItems(1)
Else: MsgBox "User cancelled selection"
Exit Sub
End If
''/// create new workbook
Set oNewBk = Workbooks.Add
ActiveWorkbook.SaveAs sFldr & Application.PathSeparator & "UniqueEntries.xlsx"
sFilName = Dir(sFldr & "\*.xls*")
Do While sFilName > "" And sFilName <> oNewBk.Name
Set oWb = Workbooks.Open(sFldr & "\" & sFilName)
lRw = Cells(Rows.Count, 1).End(xlUp).Row
Set List = CreateObject("Scripting.Dictionary")
With ActiveSheet
For Each rRng In .Range(.Cells(2, 1), .Cells(lRw, 1))
If Not List.Exists(rRng.Value) Then List.Add rRng.Value, Nothing
Next
End With
With oNewBk.Sheets(1)
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Value = oWb.Name
.Cells(.Rows.Count, 2).End(xlUp).Offset(1).Value = List.Count
End With
oWb.Close SaveChanges:=False ''///Close opened worbook w/o saving, change as needed
Set List = Nothing
sFilName = Dir()
Loop
MsgBox "All files updated", vbInformation, "Success"
End SubHi Roy,
Greetings!
Thanks for your kind help. Only one observation.
1) In excel files where there is no data the count is returned as 1 unique value.
2) Please advise can the count be returned as 0.
Hi Roy,
Greetings!
Request to consider the below.
1) In excel files where there is no data the count is returned as 1 unique value.
2) Please advise can the count be returned as 0.
3) Now there is a small change in the format. The data will be in column "M" for all the excel files in the folder. As other details are filled in the remaining columns.
4) The excel files in the folder are Xlsx format.
Request to do the needful.
Try this
Sub LoopFiles()
Dim oWb As Workbook, oNewBk As Workbook
Dim rRng As Range, rData As Range
Dim lRw As Long
Dim sFldr As String, sFilName As String
Dim fDialog As Object, List As Object
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
If fDialog.Show = -1 Then
sFldr = fDialog.SelectedItems(1)
Else: MsgBox "User cancelled selection"
Exit Sub
End If
''/// create new workbook
Set oNewBk = Workbooks.Add
ActiveWorkbook.SaveAs sFldr & Application.PathSeparator & "UniqueEntries.xlsx"
sFilName = Dir(sFldr & "\*.xls*")
Do While sFilName > "" And sFilName <> oNewBk.Name
Set oWb = Workbooks.Open(sFldr & "\" & sFilName)
lRw = Cells(Rows.Count, 13).End(xlUp).Row
Set List = CreateObject("Scripting.Dictionary")
With ActiveSheet
Set rData = .Range(.Cells(2, 13), .Cells(lRw, 13))
Select Case Application.WorksheetFunction.Count(rData)
Case 0
Case Else
For Each rRng In rData
If Not List.Exists(rRng.Value) Then List.Add rRng.Value, Nothing
Next
End Select
End With
With oNewBk.Sheets(1)
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Value = oWb.Name
.Cells(.Rows.Count, 2).End(xlUp).Offset(1).Value = List.Count
End With
oWb.Close SaveChanges:=False ''///Close opened worbook w/o saving, change as needed
Set List = Nothing
sFilName = Dir()
Loop
MsgBox "All files updated", vbInformation, "Success"
End SubHi Roy,
I am sorry to trouble you. After running the above code I see for a few files the count is returned as 0, however there is data in those files in column "M".
Hi Roy,
Request you to please assist me.
I'll have a look as soon as I can. I have a busy week at the moment.
Attach your latest workbook.
Don’t have an account yet? Register yourself now and be a part of our community!