Nov 14 2019 02:42 PM
I have a large spreadsheet of data from a registration system that I'm trying to figure out a way to extract the "coach" data from only and place it into a new sheet. Below is a representation of the data within the large spreadsheet (although there are many additional columns on either side of these, and many more rows).
I would like to search the "coach" name columns for non-blank entries and create a new sheet of all the unique coach names and associated contact info.
Does anyone have a suggestion on how to accomplish this?
Thanks for any help!
Nov 14 2019 08:01 PM
SolutionFirst of all, it's always good to upload a sample excel file instead of image so that we are not required to retype your data to test the solution.
Based on your sample data, you may try something like this to get the unique coach names on another sheet.
Sub GetUniqueCoachNames()
Dim wsData As Worksheet
Dim wsReport As Worksheet
Dim lr As Long
Dim col As Long
Dim i As Long
Dim j As Long
Dim arr As Variant
Dim arrOut() As Variant
Dim dict As Object
Dim it As Variant
Application.ScreenUpdating = False
Set wsData = Worksheets("Sheet1") 'Sheet with Data
On Error Resume Next
Set wsReport = Worksheets("Unique Coach Names") 'Name of Sheet with unique coach names that would be inserted
wsReport.Range("A1").CurrentRegion.Offset(1).Clear
On Error GoTo 0
If wsReport Is Nothing Then
Set wsReport = Worksheets.Add(after:=wsData)
wsReport.Name = "Unique Coach Names"
With wsReport.Range("A1:C1")
.Value = Array("Coach Name", "Coach Email", "Coach Phone")
.Borders.Color = vbBlack
.Font.Size = 12
.Font.Bold = True
End With
End If
lr = wsData.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set dict = CreateObject("Scripting.Dictionary")
For col = 1 To 4 Step 3
arr = wsData.Range(wsData.Cells(2, col), wsData.Cells(lr, col + 2)).Value
For i = 1 To UBound(arr, 1)
If arr(i, 1) <> "" Then
dict.Item(arr(i, 1) & "^" & arr(i, 2) & "^" & arr(i, 3)) = ""
End If
Next i
Next col
ReDim arrOut(1 To dict.Count, 1 To 3)
For Each it In dict.keys
j = j + 1
arrOut(j, 1) = Split(it, "^")(0)
arrOut(j, 2) = Split(it, "^")(1)
arrOut(j, 3) = Split(it, "^")(2)
Next it
With wsReport.Range("A2").Resize(j, 3)
.Value = arrOut
.Borders.Color = vbBlack
End With
wsReport.Select
wsReport.UsedRange.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
In the attached, click the button called "Get Unique Coach Names" on Sheet1 to run the code.
Nov 15 2019 12:32 PM
@Subodh_Tiwari_sktneer thank you very much! This is fantastic!
Apologies for not supplying the spreadsheet data. This is my first time doing this, so wasn't sure what I should provide.
I think I was able to tweak your macro to work for my larger spreadsheet by doing the following:
Did I do this correctly?
Thank you so much, again, this is very helpful!
Nov 15 2019 07:46 PM
You're welcome@jaydub66!
Yes, you did it correctly.
Considering the name of the data sheet is not fixed, you may either use the Sheet CodeName or the Sheet Index which would be 1 as there would only be one worksheet in the Workbook.
Also, you may use the Column Letter to decide the first name header and the last name header in the data set.
Please try this tweaked code and let me know if that works well on your end...
Sub GetUniqueCoachNames()
Dim wsData As Worksheet
Dim wsReport As Worksheet
Dim lr As Long
Dim col As Long
Dim i As Long
Dim j As Long
Dim arr As Variant
Dim arrOut() As Variant
Dim dict As Object
Dim it As Variant
Dim StartCol As String
Dim EndCol As String
Application.ScreenUpdating = False
Set wsData = Sheet1 'Using the Sheet CodeName of the only Sheet in the Workbook
'OR use the Sheet Index to set the only Sheet in the workbook like this
'Uncomment the below line by removing the single quote in the beginning if the above line doesn't work for you
'Set wsData = ThisWorkbook.Worksheets(1)
'Using Column Letter to decide the first Coach Name header and the last Coach Name header
StartCol = "A1"
EndCol = "D1"
On Error Resume Next
Set wsReport = Worksheets("Unique Coach Names") 'Name of Sheet with unique coach names that would be inserted
wsReport.Range("A1").CurrentRegion.Offset(1).Clear
On Error GoTo 0
If wsReport Is Nothing Then
Set wsReport = Worksheets.Add(after:=wsData)
wsReport.Name = "Unique Coach Names"
With wsReport.Range("A1:C1")
.Value = Array("Coach Name", "Coach Email", "Coach Phone")
.Borders.Color = vbBlack
.Font.Size = 12
.Font.Bold = True
End With
End If
lr = wsData.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set dict = CreateObject("Scripting.Dictionary")
For col = Range(StartCol).Column To Range(EndCol).Column Step 3
arr = wsData.Range(wsData.Cells(2, col), wsData.Cells(lr, col + 2)).Value
For i = 1 To UBound(arr, 1)
If arr(i, 1) <> "" Then
dict.Item(arr(i, 1) & "^" & arr(i, 2) & "^" & arr(i, 3)) = ""
End If
Next i
Next col
ReDim arrOut(1 To dict.Count, 1 To 3)
For Each it In dict.keys
j = j + 1
arrOut(j, 1) = Split(it, "^")(0)
arrOut(j, 2) = Split(it, "^")(1)
arrOut(j, 3) = Split(it, "^")(2)
Next it
With wsReport.Range("A2").Resize(j, 3)
.Value = arrOut
.Borders.Color = vbBlack
End With
wsReport.Select
wsReport.UsedRange.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
Nov 20 2019 10:55 AM
@Subodh_Tiwari_sktneer sorry to take so long to get back to you! I finally had a chance to run this, after modifying as suggested. However, the macro breaks at the following line:
"lr = wsData.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row"
Says "Runtime error '91'...Object variable or With block variable not set"
Did I change something I shouldn't have?
Nov 20 2019 11:55 AM
wsData is a variable which holds the reference of Sheet with data and it is set in this line...
Application.ScreenUpdating = False
Set wsData = Sheet1 'Using the Sheet CodeName of the only Sheet in the Workbook
Are you sure you have that line in your code?
Just pay attention to the comments added in the code and I am sure you will be able to tweak it as per your requirement.
Nov 14 2019 08:01 PM
SolutionFirst of all, it's always good to upload a sample excel file instead of image so that we are not required to retype your data to test the solution.
Based on your sample data, you may try something like this to get the unique coach names on another sheet.
Sub GetUniqueCoachNames()
Dim wsData As Worksheet
Dim wsReport As Worksheet
Dim lr As Long
Dim col As Long
Dim i As Long
Dim j As Long
Dim arr As Variant
Dim arrOut() As Variant
Dim dict As Object
Dim it As Variant
Application.ScreenUpdating = False
Set wsData = Worksheets("Sheet1") 'Sheet with Data
On Error Resume Next
Set wsReport = Worksheets("Unique Coach Names") 'Name of Sheet with unique coach names that would be inserted
wsReport.Range("A1").CurrentRegion.Offset(1).Clear
On Error GoTo 0
If wsReport Is Nothing Then
Set wsReport = Worksheets.Add(after:=wsData)
wsReport.Name = "Unique Coach Names"
With wsReport.Range("A1:C1")
.Value = Array("Coach Name", "Coach Email", "Coach Phone")
.Borders.Color = vbBlack
.Font.Size = 12
.Font.Bold = True
End With
End If
lr = wsData.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set dict = CreateObject("Scripting.Dictionary")
For col = 1 To 4 Step 3
arr = wsData.Range(wsData.Cells(2, col), wsData.Cells(lr, col + 2)).Value
For i = 1 To UBound(arr, 1)
If arr(i, 1) <> "" Then
dict.Item(arr(i, 1) & "^" & arr(i, 2) & "^" & arr(i, 3)) = ""
End If
Next i
Next col
ReDim arrOut(1 To dict.Count, 1 To 3)
For Each it In dict.keys
j = j + 1
arrOut(j, 1) = Split(it, "^")(0)
arrOut(j, 2) = Split(it, "^")(1)
arrOut(j, 3) = Split(it, "^")(2)
Next it
With wsReport.Range("A2").Resize(j, 3)
.Value = arrOut
.Borders.Color = vbBlack
End With
wsReport.Select
wsReport.UsedRange.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
In the attached, click the button called "Get Unique Coach Names" on Sheet1 to run the code.