VBA: Merging columns based on header

[ruinedelf]

Good morrow! Got a question, I would like a VBA script that can merge columns based on the header. For instance:

	Analyte 1	Analyte 2	Analyte 1
Sample 1	234	2344
Sample 2		665	543

becomes

	Analyte 1	Analyte 2
Sample 1	234	2344
Sample 2	543	665

How this is done isn't a major factor, but there may be more than 1 column that needs to be merged, and more than 1 row that needs merging.

I actually had a working script for this made up by someone else that did exactly what I needed, but as it uses dictionaries, it requires the Microsoft Scripting Runtime Reference to be enabled and I will be deploying this to people who won't and are unable to add it. See below.

Option Explicit

Public Sub MergeColumns()
    Const HDR As Long = 1      'header row
    Const HDC As Long = 3       '(first) header column

    Dim ws As Worksheet, lRow As Long, lCol As Long, hRow As Variant, i As Long
    Dim ac As Object, dc As Object, c1 As Variant, c2 As Variant
    Set ac = CreateObject("Scripting.Dictionary")
    Set dc = CreateObject("Scripting.Dictionary")
    Dim itm As Variant, dCols As Range, d As Range, tr As String
    Set ws = ThisWorkbook.Worksheets("ALS Import")
    lRow = ws.Cells(ws.Rows.Count, HDC).End(xlUp).Row
    lCol = ws.Cells(HDR, ws.Columns.Count).End(xlToLeft).Column

    If lRow >= HDR And lCol > HDC Then
        hRow = ws.Range(ws.Cells(HDR, HDC), ws.Cells(HDR, lCol)).Value2

        Application.ScreenUpdating = False

        For i = 1 To lCol - HDC + 1 'find dupes ---------------------------------------------
            tr = Trim(hRow(1, i))
            If Len(tr) > 0 Then
                If Not ac.Exists(tr) Then
                    ac.Add tr, i + HDC - 1
                Else
                    ' If the key exists in the 'ac' dictionary, but not in 'dc', add to 'dc'
                    If Not dc.Exists(ac(tr)) Then
                        dc.Add ac(tr), i + HDC - 1
                    End If
                End If
            End If
        Next
      Application.ScreenUpdating = False
      For Each itm In dc 'merge columns ---------------------------------------------------
         c1 = ws.Range(ws.Cells(HDR, itm), ws.Cells(lRow, itm)).Value2
         c2 = ws.Range(ws.Cells(HDR, dc(itm)), ws.Cells(lRow, dc(itm))).Value2
         For i = 1 To lRow - HDR + 1
            If Len(Trim(c1(i, 1))) = 0 Then c1(i, 1) = c2(i, 1) 'trimms blanks
         Next
         ws.Range(ws.Cells(HDR, itm), ws.Cells(lRow, itm)).Value2 = c1
      Next
      For Each itm In dc 'delete duplicate columns ----------------------------------------
         Set d = ws.Cells(HDR, dc(itm))
         If dCols Is Nothing Then Set dCols = d Else Set dCols = Union(dCols, d)
      Next
      If Not dCols Is Nothing Then dCols.EntireColumn.Delete
      Application.ScreenUpdating = True
   End If
End Sub

Any ideas what I'd be able to dance with?

 

[ruinedelf]

@eiloken Hmm, something strange is happening. For the most part, it's fine, but sometimes it still does that weird stacking thing. I'll need to dig more into it next week (so nothing'll happen for a bit), but it might be close proximity in a large dataset (448 columns), where it does a match right next to another. I can't show you the whole dataset, but the relevant part looks something like this:

Transposed so you can see, it looks like this:

Before:

After:

Yellow shows a set of data that worked properly: it checks the header row (column 1 transposed), finds the duplicates, merges them, and removes the extras.

Blue is where the issue happens: It's bringing in a random header from further down the list of column headers and placing it into the data row, then appending the data row under it. It does successfully remove the duplicates though.

I'm sorry I can't show you the full data set, it seems to work when I tried it a few times, and it DOES work for some of the cases, but not all of them. Would you have any ideas? Thank you!

 

[eiloken]

@eiloken Hmm, something strange is happening. For the most part, it's fine, but sometimes it still does that weird stacking thing. I'll need to dig more into it next week (so nothing'll happen for a bit), but it might be close proximity in a large dataset (448 columns), where it does a match right next to another. I can't show you the whole dataset, but the relevant part looks something like this:

View attachment 103212

Transposed so you can see, it looks like this:

Before:
View attachment 103218
After:
View attachment 103219

Yellow shows a set of data that worked properly: it checks the header row (column 1 transposed), finds the duplicates, merges them, and removes the extras.

Blue is where the issue happens: It's bringing in a random header from further down the list of column headers and placing it into the data row, then appending the data row under it. It does successfully remove the duplicates though.

I'm sorry I can't show you the full data set, it seems to work when I tried it a few times, and it DOES work for some of the cases, but not all of them. Would you have any ideas? Thank you!

Oh i see, that code before has some problem, i think this will resolve it:

Sub MergeColumns()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim cll As Range, mcll As Range, ccll As Range, title As Range, delCol As Range
    Dim i As Integer
    i = Selection.Rows.Count
    Set title = Range(Selection.Cells(1), Selection.Cells(Selection.Cells.Count).Offset(-i + 1))
    For Each cll In title
        If Not IsEmpty(cll) Then
            If delCol Is Nothing Then
                GoTo S2
            Else
                If Intersect(cll, delCol) Is Nothing Then GoTo S2 Else GoTo S3
            End If
S2:
            For Each mcll In title
                If Intersect(mcll, cll) Is Nothing Then
                    If delCol Is Nothing Then
                        GoTo S0
                    Else
                        If Intersect(mcll, delCol) Is Nothing Then GoTo S0 Else GoTo S1
                    End If
S0:
                    If cll.Value = mcll.Value Then
                        If Lr(mcll.Column) > i Then
                            For Each ccll In Range(mcll.Offset(i), mcll.Offset(Lr(mcll.Column) - 1))
                                If Not IsEmpty(ccll) Then cll.Offset(Lr(cll.Column)).Value = ccll.Value
                            Next ccll
                        End If
                        If delCol Is Nothing Then
                            Set delCol = Columns(mcll.Column)
                        Else
                            Set delCol = Union(delCol, Columns(mcll.Column))
                        End If
                    End If
                End If
S1:
            Next mcll
        End If
S3:
    Next cll
    If Not delCol Is Nothing Then delCol.Delete Shift:=xlToLeft
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Private Function Lr(ByVal col As Integer) As Long
    Lr = Cells(Rows.Count, col).End(xlUp).Row
End Function

 

[ruinedelf]

That works a charm, thanks a lot!