Identifying Similar Column Headers using a VBA Macro

[aryaden]

I Currently have a sheet with multiple columns: Monday1, Monday2, Monday3, Tuesday, Wednesday1, Wednesday2, Thursday, Friday...

I want to create a macro that can identify all the Columns with "Monday" and create a worksheet in the same workbook with those columns listed. Ideally I'd be able to do the same for Wednesday.

I have to deal with many workbooks with column titles that are similar that need to be selected and made into a new worksheet. I am looking to make a macro that can select and group similar column titles regardless of the actual text. For example, if column titles have the same first 5 letters, is there anyway to identify and select those?

 

[shknbk2]

Welcome to the forum.

I got something to work with random data based on choosing the columns based on the first 5 characters as a start. I'm guessing that your headers are in the first row starting at A1. If not, the code will have to be revised.

Note that this requires adding a module file from Chip Pearson's website. In the introduction on the page, you will find a link to a zip file with a .bas file that you can import into your workbook. Once you unzip the file, you can drag and drop it into the VBAProject for your workbook or us File->Insert file to find it. It will put in a module called modFindAll64 into your VBE project.

If you do not include this file, the code will not compile at the Set rTemp = FindAll line.

Sub headers()
    Dim c1 As Collection
    Dim cHeaders As Collection
    Dim rHeaders As Range, rTemp As Range
    Dim a As Variant
    Dim i As Integer
    Dim left5 As String
    Dim shOld As Worksheet, shNew As Worksheet
    
    'Get header row
    Set rHeaders = Range("A1").Resize(1, Range("A1").CurrentRegion.Columns.Count)
    'Fill array with array of header names
    a = rHeaders.Value
    Set c1 = New Collection
    Set cHeaders = New Collection
    'Fill first collection with header values
    '(using a collection makes it easy below to delete used values)
    For i = LBound(a, 2) To UBound(a, 2)
        c1.Add a(1, i)
    Next
    'For each item in the collection, get the first 5 letters of item 1
    'and add it to the cHeaders collection; any header with the same 5
    'letters is removed
    Do While c1.Count > 0
        left5 = Left(c1(1), 5)
        cHeaders.Add left5
        For i = c1.Count To 2 Step -1
            If Left(c1.Item(i), 5) = left5 Then
                c1.Remove i
            End If
        Next i
        c1.Remove 1
    Loop
    'cHeaders should now hold 1 entry for each unique 5-letter header
    Set shOld = ActiveSheet
    'Create a new sheet for each cHeader and copy the data from the
    'respective columns
    'Requires "modFindAll64" module file from http://www.cpearson.com/excel/findall.aspx
    For i = 1 To cHeaders.Count
        Set shNew = Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
        shNew.Name = cHeaders(i)
        shOld.Select
        Set rTemp = FindAll(rHeaders, cHeaders(i), , xlPart)
        rTemp.EntireColumn.Copy shNew.Range("A1")
    Next i
    shOld.Select
End Sub

This is my test data:

Headers to sheets.xlsm
	A	B	C	D	E	F	G	H
1	Monday1	Monday2	Monday3	Tuesday	Wednesday1	Wednesday2	Thursday	Friday
2	379	81	162	451	426	261	10	296
3	388	411	313	172	355	263	445	217
4	71	297	332	416	427	488	113	177
5	344	19	72	409	230	158	425	449
6	477	53	278	296	356	500	119	250
7	248	329	93	185	267	110	208	37
8	438	248	380	61	177	150	240	428
9	401	113	196	327	57	43	274	339
10	139	402	412	62	223	2	142	259
11	364	26	377	64	374	362	187	205
12	313	424	72	351	98	118	179	189
13	65	455	189	187	7	187	112	370
14	112	206	40	278	168	169	488	120
15	187	272	199	324	320	403	113	169
16	129	448	219	297	275	203	301	396
17	157	350	282	119	131	428	416	331
18	356	182	388	198	491	462	142	475
Sheet1

The code generated these sheets:

"Monda" looks like this:

Headers to sheets.xlsm
	A	B	C
1	Monday1	Monday2	Monday3
2	379	81	162
3	388	411	313
4	71	297	332
5	344	19	72
6	477	53	278
7	248	329	93
8	438	248	380
9	401	113	196
10	139	402	412
11	364	26	377
12	313	424	72
13	65	455	189
14	112	206	40
15	187	272	199
16	129	448	219
17	157	350	282
18	356	182	388
Monda

 

[jolivanes]

Different approach

Sub Maybe_So()
Dim lr As Long, lc As Long, i As Long, x As Long
Dim wsArr, transf As String
lr = ActiveSheet.Cells.Find("*", , , , xlByRows, xlPrevious).Row
lc = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column
wsArr = ActiveSheet.Cells(1, 1).Resize(lr, lc).Value
transf = Application.InputBox("Enter the day to be transferred.", "Column Headers Input.", , , , , , 2)
ThisWorkbook.Sheets.Add(, Sheets(Sheets.Count)).Name = WorksheetFunction.Proper(transf)
x = 1
    For i = LBound(wsArr, 2) To UBound(wsArr, 2)
        If Left(LCase(wsArr(1, i)), Len(transf)) = LCase(transf) Then
            Cells(1, x).Resize(UBound(wsArr)) = Application.Index(wsArr, , i)
            x = x + 1
        End If
    Next i
End Sub

 

[Peter_SSs]

Welcome to the MrExcel board!

Yet another possibility.
I have assumed the original data is on sheet 'Main'

Sub GenerateSheet()
  Dim Pref As String
  Dim c As Long
 
  Pref = InputBox("Enter start of common name (as many characters as you like)")
  If Len(Pref) > 0 Then
    Application.ScreenUpdating = False
    Sheets("Main").Copy After:=Sheets("Main")
    With Sheets(Sheets("Main").Index + 1)
      For c = .Cells(1, Columns.Count).End(xlToLeft).Column To 1 Step -1
        If Not LCase(.Cells(1, c).Text) Like (LCase(Pref) & "*") Then .Columns(c).Delete
      Next c
      On Error Resume Next
      .Name = Pref
      On Error GoTo 0
    End With
    Application.ScreenUpdating = True
  End If
End Sub

 

[jolivanes]

Insert a UserForm and on it add a Label and a Listbox named ListBox1
Copy following code into the UserForm Code Window.

Private Sub ListBox1_Click()
Dim lr As Long, lc As Long, i As Long, x As Long
Dim wsArr, transf As String, nm As String
nm = ActiveSheet.Name
lr = ActiveSheet.Cells.Find("*", , , , xlByRows, xlPrevious).Row
lc = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column
wsArr = ActiveSheet.Cells(1, 1).Resize(lr, lc).Value
transf = ListBox1
Unload Me
Application.ScreenUpdating = False
ThisWorkbook.Sheets.Add(, Sheets(Sheets.Count)).Name = WorksheetFunction.Proper(transf)
x = 1
    For i = LBound(wsArr, 2) To UBound(wsArr, 2)
        If Left(LCase(wsArr(1, i)), Len(transf)) = LCase(transf) Then
            Cells(1, x).Resize(UBound(wsArr)) = Application.Index(wsArr, , i)
            x = x + 1
        End If
    Next i
Sheets(nm).Activate
Application.ScreenUpdating = True
End Sub

Private Sub UserForm_Initialize()
    ListBox1.List = Array("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday")
End Sub

Put the following code in a regular Module

Sub Get_It()
    UserForm1.Show
End Sub

Run the "UserForm1.Show" Macro, select a day from the listbox and that's it, finished.

You can set the dimensions of the UserForm, ListBox and Label in the Items properties windows of each.
I have the following:
Userform: Caption "Select a day.", Height 180, Left 0, Top 0, Width 126.
Label: Caption "Select a day to transfer below.", Height 18, Left 6, Top 6, Width 108.
ListBox1: Font Tahoma Bold Size 10, Height 110, Left 6, Top 30, Width 108.

 

[Peter_SSs]

I have to deal with many workbooks with column titles that are similar that need to be selected and made into a new worksheet. I am looking to make a macro that can select and group similar column titles regardless of the actual text. For example, if column titles have the same first 5 letters, is there anyway to identify and select those?

I think that I may not have addressed that correctly with my previous code. This lets you decide how many leading characters should be matched and splits off a sheet based on that number of leading characters.

Sub GenerateSheets_v2()
  Dim d As Object
  Dim Ky As Variant
  Dim wsOrig As Worksheet
  Dim Pref As String
  Dim c As Long
  
  Const OrigShtName As String = "Main"  '<- Edit to suit
  
  Pref = InputBox("Match first how many characters?")
  If IsNumeric(Pref) Then
    Application.ScreenUpdating = False
    Set d = CreateObject("Scripting.Dictionary")
    d.compareMode = 1
    Set wsOrig = Sheets(OrigShtName)
    With wsOrig
      For c = .Cells(1, Columns.Count).End(xlToLeft).Column To 1 Step -1
        If Len(.Cells(1, c).Text) > 0 Then d(Left(.Cells(1, c).Text, Pref)) = Empty
      Next c
    End With
    For Each Ky In d.Keys
      wsOrig.Copy After:=wsOrig
      With Sheets(wsOrig.Index + 1)
        For c = .Cells(1, Columns.Count).End(xlToLeft).Column To 1 Step -1
          If Not LCase(.Cells(1, c).Text) Like LCase(Ky) & "*" Then .Columns(c).Delete
        Next c
        On Error Resume Next
        .Name = Ky & "_"
        On Error GoTo 0
      End With
    Next Ky
    Application.ScreenUpdating = True
  End If
End Sub

With your sample headings in post #1 for example, and entering 5 in the input box, sheets 'Monda_', 'Tuesd_', ... , 'Frida_' would be created.
If the headings were full month names and 3 was entered then the sheets would be 'Jan_', Feb_' etc

 

[aryaden]

Thank you all for the solutions! This has been very useful as I am new to VBA. I am receiving the data from another person and after a meeting today the format in which I receive the data has changed and my problem has changed a little. I created a mock sheet to demonstrate.

Book1
	A	B	C	D	E	F	G	H	I	J
1	Description	Monday	Monday	Monday	Tuesday	Wednesday	Thursday	Friday	Friday	Saturday
2		1	2	3	1	1	1	1	2	1
3	AAAA	X				X			X
4	BBBB				X		X		X	X
5	CCCC		X	X	X	X
6	DDDD	X					X	X		X
7	EEEE					X			X	X
8	FFFF		X		X		X	X		X
9	GGGG		X		X	X
Sheet1

Is there anyway for me to identify all duplicates in Row 1, identify the text in Column A that at least one of the duplicates has an "X" in, and make a new sheet with the descriptions in Colum A that are relevant to the duplicate values in Row 1?

These are what the output sheets would be for the example sheet I included:

For Monday: The descriptions which used to be "BBBB" and "EEEE" are omitted as none of the Mondays have "X"s in these rows

Book1
	A	B	C	D
1	Description	Monday	Monday	Monday
2		1	2	3
3	AAAA	X
4	CCCC		X	X
5	DDDD	X
6	FFFF		X
7	GGGG		X
8
Sheet2

For Friday: The descriptions which used to be "CCCC" and "GGGG" are omitted as none of the Fridays have "X"s in these rows

Book1
	A	B	C
1	Description	Friday	Friday
2		1	2
3	AAAA		X
4	BBBB		X
5	DDDD	X
6	EEEE		X
7	FFFF	X
Sheet3

Note: The Description values and rows (days in the example included) change in every workbook I get. I am a college intern that would really appreciate the help as I have about 40 different workbooks like these to sort and will probably be getting more in the future!

Thank you so much!

 

[Peter_SSs]

Assuming that the data is on the left hand (or only) worksheet in the workbook, try this with a copy.

Sub Make_Sheets()
  Dim d As Object
  Dim Ky As Variant
  Dim wsOrig As Worksheet
  Dim cell As Range
  Dim col As Long, LastCol As Long
  
  Set wsOrig = Sheets(1)
  Set d = CreateObject("Scripting.Dictionary")
  With wsOrig
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    For Each cell In .Range("B1").Resize(, LastCol - 1)
      d(cell.Value) = Empty
    Next cell
  End With
  Application.ScreenUpdating = False
  For Each Ky In d.Keys
    wsOrig.Copy After:=Sheets(Sheets.Count)
    With Sheets(Sheets.Count)
      For col = LastCol To 2 Step -1
        If Not .Cells(1, col).Text = Ky Then .Columns(col).Delete
      Next col
      With .UsedRange
        For col = 2 To .Columns.Count
          .AutoFilter Field:=col, Criteria1:=""
        Next col
        .Offset(1).EntireRow.Delete
      End With
      .Name = Ky
      .AutoFilterMode = False
    End With
  Next Ky
  wsOrig.Activate
  Application.ScreenUpdating = True
End Sub

 

[aryaden]

Thank you so much! That worked and the code was concise and easy to understand!

 

[aryaden]

Assuming that the data is on the left hand (or only) worksheet in the workbook, try this with a copy.

Sub Make_Sheets()
  Dim d As Object
  Dim Ky As Variant
  Dim wsOrig As Worksheet
  Dim cell As Range
  Dim col As Long, LastCol As Long
 
  Set wsOrig = Sheets(1)
  Set d = CreateObject("Scripting.Dictionary")
  With wsOrig
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    For Each cell In .Range("B1").Resize(, LastCol - 1)
      d(cell.Value) = Empty
    Next cell
  End With
  Application.ScreenUpdating = False
  For Each Ky In d.Keys
    wsOrig.Copy After:=Sheets(Sheets.Count)
    With Sheets(Sheets.Count)
      For col = LastCol To 2 Step -1
        If Not .Cells(1, col).Text = Ky Then .Columns(col).Delete
      Next col
      With .UsedRange
        For col = 2 To .Columns.Count
          .AutoFilter Field:=col, Criteria1:=""
        Next col
        .Offset(1).EntireRow.Delete
      End With
      .Name = Ky
      .AutoFilterMode = False
    End With
  Next Ky
  wsOrig.Activate
  Application.ScreenUpdating = True
End Sub

Hi Peter_SSs,

Is there anyway to modify this code so that the days there aren't duplicates of, such as Tuesday, Wednesday, Thursday, and Saturday (from the example), would not have the column with the Xs in the output Sheet?

So for Tuesday it would be:

Example Sheet.xlsm
	A	B
1	Description
2
3	BBBB
4	CCCC
5	FFFF
6	GGGG
Sheet5

But Monday would remain:

Example Sheet.xlsm
	A	B	C	D
1	Description	Monday	Monday	Monday
2		1	2	3
3	AAAA	X
4	CCCC		X	X
5	DDDD	X
6	FFFF		X
7	GGGG		X
8
Sheet5

Thank you again for all the help!