VBA: Merging rows after a particular row, based off of matching entries in column

ruinedelf

New Member
Joined
Dec 6, 2023
Messages
35
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
  2. MacOS
Hi all! Got another question for ya'll! This is similar to the one eiloken helped me with earlier, but it's different enough I'd like to request help here as well.

As before, the workbook needs to be OS agnostic (on both Windows and Mac at least) and as Mac does not have access to Microsoft Scripting Runtime, I'm not able to use the script I got from somewhere else that uses Dictionaries.

I have a table that looks like this:

BatchSampleAnalyte 1Analyte 2Analyte 3Analyte 4Analyte 5Analyte 6Analyte 7Analyte 8Analyte 9Analyte 10Analyte 11Analyte 12Analyte 13Analyte 14
Batch 1Sample 1<0.1<5<0.12.330.61.6<0.10.7<112.9
Batch 1Sample 140159.944050
Batch 1Sample 2<0.1<5<0.12.724.42<0.10.7<116.1
Batch 1Sample 237757.54.15190

I would like a script that would be able to merge the rows based on column B. As you can see, there are two Sample 1s and two Sample 2s, with alternating empty spots in both rows. I would like the script to be able to merge them so it would look like this:

BatchSampleAnalyte 1Analyte 2Analyte 3Analyte 4Analyte 5Analyte 6Analyte 7Analyte 8Analyte 9Analyte 10Analyte 11Analyte 12Analyte 13Analyte 14
Batch 1Sample 1<0.1<5<0.12.330.64011.6<0.159.90.74<1405012.9
Batch 1Sample 2<0.1<5<0.12.724.43772<0.157.50.74.1<1519016.1

However, there's a catch: I would like the script to only check from row 61 onwards. Anything above row 61 should not be touched.

This is the script that I have been using:
VBA Code:
Sub mergeRows()
    Const HDR As Long = 61 ' Header row
    Const col As Long = 2 ' Column used for merging rows
    Dim ws As Worksheet, lastRow As Long, i As Long
    Set ws = ThisWorkbook.Worksheets("ALS Import")
    lastRow = ws.Cells(ws.Rows.Count, col).End(xlUp).Row

    Dim ac As New Dictionary, dc As New Dictionary
    Dim itm As Variant, dRows As Range, d As Range, tr As String

    If lastRow >= HDR Then
        Application.ScreenUpdating = False

        For i = HDR To lastRow ' Find duplicate values in the chosen column
            tr = Trim(ws.Cells(i, col).Value)
            If Len(tr) > 0 Then
                If Not ac.Exists(tr) Then
                    ac.Add tr, i
                Else
                    ' If the key exists in the 'ac' dictionary, add to 'dc' for merging
                    If Not dc.Exists(ac(tr)) Then
                        dc.Add ac(tr), i
                    End If
                End If
            End If
        Next i

        For Each itm In dc ' Merge rows ---------------------------------------------------
            ' Combines rows where the chosen column values match
            For i = 1 To ws.Cells(itm, ws.Columns.Count).End(xlToLeft).Column
                If Len(Trim(ws.Cells(itm, i).Value)) = 0 Then
                    ws.Cells(itm, i).Value = ws.Cells(dc(itm), i).Value
                End If
            Next i
        Next

        For Each itm In dc ' Deletes the duplicate rows -----------------------------------
            Set d = ws.Cells(dc(itm), col)
            If dRows Is Nothing Then
                Set dRows = d
            Else
                Set dRows = Union(dRows, d)
            End If
        Next

        If Not dRows Is Nothing Then dRows.EntireRow.Delete

        Application.ScreenUpdating = True
    End If
End Sub
Hope this won't be too difficult! Thanks!
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Will there ever be more than two of each 'Sample'?
 
Upvote 0
For example, if there are only two of each 'Sample' you could use something like the below to keep it simple:
VBA Code:
Sub test()
    Dim x As Long, y As Long, arr1 As Variant, arr2 As Variant
 
    For x = Cells(Rows.Count, 1).End(xlUp).Row - 1 To 62 Step -2
        arr1 = Range(Cells(x, 3), Cells(x, 16)).Value
        arr2 = Range(Cells(x + 1, 3), Cells(x + 1, 16)).Value
        For y = 1 To UBound(arr1, 2)
            If arr1(1, y) = "" Then arr1(1, y) = arr2(1, y)
        Next y
        Range(Cells(x, 3), Cells(x, 16)) = arr1
        Rows(x + 1).EntireRow.Delete
    Next x
End Sub

This will only work if there are always two of each 'Sample'
 
Last edited:
Upvote 0
Thanks for the reply! Honestly, it's really up to our client whether or not there's more than two. Usually, it's only the one, only sometimes do we get the two. I haven't seen three yet and hoping never, but you never know.

I'm away from my computer until tomorrow, I'll give the script a spin then! Just checking now, will the script interfere with anything with only one? For instance, will there be any funny business with the following:

Sample 1
Sample 1
Sample 2
Sample 3
Sample 3

Will Sample 1 and 3 be safely merged and Sample 3 be left alone?

Thanks again!
 
Upvote 0
No, in that case - post 3 will not be worth your time trying. I will however, look at a different solution based on post 3 that will take into account 1 as well as two or more 'Samples' rows, keeping in mind not to use the Scripting Runtime & dictionary.
 
Upvote 0
Thank you for your patience! And I made a small typo there, hopefully you understood: Only rows with multiple duplicates should be merged, singles should be left alone. Hope that was clear!
 
Upvote 0
Sorry for another bump, but just to remind anyone reading this that the majority of the time, there'll only be one of each sample, so the script needs to be tolerant of that. In the case of 2 or more, merge, in the case of 1, ignore.

Hope it's not too difficult, thanks!
 
Upvote 0
Are the duplicated 'Samples' always arranged one under the other or can they be in different places in the data?
 
Upvote 0
Yes, if there are duplicates, they will be under each other.
 
Upvote 0

Forum statistics

Threads
1,215,071
Messages
6,122,963
Members
449,094
Latest member
Anshu121

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top