Good morrow! Got a question, I would like a VBA script that can merge columns based on the header. For instance:
becomes
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.
Any ideas what I'd be able to dance with?
| 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.
VBA Code:
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 SubAny ideas what I'd be able to dance with?
