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?

 

[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?

Try

Sub Make_Sheets_v2()
  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
        If .Columns.Count = 2 Then
          .Columns(2).Delete
        Else
          For col = 2 To .Columns.Count
            .AutoFilter Field:=col, Criteria1:=""
          Next col
          .Offset(1).EntireRow.Delete
          .Parent.AutoFilterMode = False
        End If
      End With
      .Name = Ky
    End With
  Next Ky
  wsOrig.Activate
  Application.ScreenUpdating = True
End Sub

 

[aryaden]

Try

Sub Make_Sheets_v2()
  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
        If .Columns.Count = 2 Then
          .Columns(2).Delete
        Else
          For col = 2 To .Columns.Count
            .AutoFilter Field:=col, Criteria1:=""
          Next col
          .Offset(1).EntireRow.Delete
          .Parent.AutoFilterMode = False
        End If
      End With
      .Name = Ky
    End With
  Next Ky
  wsOrig.Activate
  Application.ScreenUpdating = True
End Sub

Thank you so much for all the help! I was able to be much more productive and useful at work because of this.

 

[Peter_SSs]

You're welcome. Glad we could help.

 

[aryaden]

You're welcome. Glad we could help.

Hi I am sorry for all the questions, I just realized that I was not clear in the last question I posted.

For the days there aren't duplicates of, such as Tuesday, Wednesday, Thursday, and Saturday (from the example), I would still like the column on the left that says description to still only have the descriptions (AAAA-GGGG in example) that have an X in the column to show up, I was just trying to get rid of the column with the day listed in the first cell to disappear.

For example for Tuesday the Sheet would look like this:

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

I am sorry for the hassle and I really appreciate the help

 

[Peter_SSs]

This?

Sub Make_Sheets_v3()
  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
          .Parent.AutoFilterMode = False
          If .Columns.Count = 2 Then .Columns(2).Delete
      End With
      .Name = Ky
    End With
  Next Ky
  wsOrig.Activate
  Application.ScreenUpdating = True
End Sub

 

[aryaden]

This?

Sub Make_Sheets_v3()
  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
          .Parent.AutoFilterMode = False
          If .Columns.Count = 2 Then .Columns(2).Delete
      End With
      .Name = Ky
    End With
  Next Ky
  wsOrig.Activate
  Application.ScreenUpdating = True
End Sub

Yes that is perfect! Thank you for all the input and patience.

 

[Peter_SSs]

Cheers. Glad we got there in the end.