Copper Contributor

Nov 14, 2019

Solved

Looking for way to extract data from Excel sheet and place into new sheet

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!

excel

Formulas and Functions

Macros and VBA

Subodh_Tiwari_sktneer

Nov 15, 2019

jaydub66

First 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.

Get Unique Coach Names.xlsm22 KB

5 Replies

Subodh_Tiwari_sktneer

Silver Contributor

Nov 15, 2019

jaydub66

First 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.

Get Unique Coach Names.xlsm22 KB

jaydub66

Copper Contributor

Nov 15, 2019

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:

Set "wsData" to the name of my worksheet. Is there a way to make this assign to the only sheet available in the workbook? Just trying to see how to use this for future data dumps where the sheet name (which corresponds to the data dump file name) changes.
In the "For col = 1 To 4 Step 3" statement, I adjusted to the columns within my data file, so result was "For col = 33 To 39 Step 3" (I actually had 3 coach columns of data and not 2 like in my example). Is there a way to reference these column numbers within the code using their column names (e.g., "AG To AM Step 3")?

Did I do this correctly?

Thank you so much, again, this is very helpful!

Subodh_Tiwari_sktneer

Silver Contributor

Nov 16, 2019

You're welcomejaydub66!

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

Forum Discussion

Looking for way to extract data from Excel sheet and place into new sheet

5 Replies

Resources