1
\$\begingroup\$

I am working on a bit of a multiple part project, the goal of the project is to have a spreadsheet full of order data (order number, customer data, products ordered, prices etc) merged so that the duplicate information is grouped up.

Order data

The above is an example of what the data looks like when it comes in.

I then got it to unmerge so that it looks a little cleaner.

Unmerged data

The code used for these two steps was created with much help from this community and looks like this:

Option Explicit

Sub MergeCells()

Dim i As Long, c As Long, col As Variant

Application.DisplayAlerts = False
'Application.ScreenUpdating = false

col = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "AA", "AB", "AC", "AD", "AE", "AF", "AG", "AH", "AI", "AJ", "AK")

For c = LBound(col) To UBound(col)
    For i = Cells(Rows.Count, col(c)).End(xlUp).Row - 1 To 2 Step -1
        If Cells(i, col(c)).Value = Cells(i, col(c)).Offset(1, 0).Value And Not IsEmpty(Cells(i, col(c))) Then
            Cells(i, col(c)).Resize(2, 1).Merge
            Cells(i, col(c)).HorizontalAlignment = xlCenter
            Cells(i, col(c)).VerticalAlignment = xlCenter
        End If
    Next i
Next c

Application.DisplayAlerts = True
'Application.ScreenUpdating = True
End Sub

Then this:

Sub fixMergedCells(sh As Worksheet)
'replace merged cells by Center Acroos Selection
'high perf version using a hack: https://stackoverflow.com/a/9452164/78522
Dim c As Range, used As Range
Dim m As Range, i As Long
Dim constFla: constFla = Array(xlConstants, xlFormulas)

Set used = sh.UsedRange
For i = 0 To 1  '1 run for constants, 1 for formulas
    Err.Clear
    On Error Resume Next
    Set m = Intersect(used.Cells.SpecialCells(constFla(i)), used.Cells.SpecialCells(xlBlanks))
    On Error GoTo 0
    If Not m Is Nothing Then
        For Each c In m.Cells
            If c.MergeCells Then
                With c.MergeArea
                    'Debug.Print .Address
                    .UnMerge
                    .HorizontalAlignment = xlCenterAcrossSelection
                End With
            End If
        Next c
    End If
Next i
End Sub

And finally:

Sub fixMergedCells(Optional sh As Variant)

If IsMissing(sh) Then Set sh = ActiveSheet

sh.Cells.UnMerge

End Sub

I am currently working on two final steps, one to make sure that the data that got merged and then split will appear for each relevant line. Then I want to highlight each row that contains an order number so that we can see clearly where one order starts and another ends.

My last step of the plan is to combine all of the codes into one macro, as I want it to be easy for someone to use.

Thanks for reading, I just wanted to share what I've gotten so far and see what y'all think of my plan :)

\$\endgroup\$
2
  • 2
    \$\begingroup\$ Welcome to Code Review SE! This looks like a good first question. Next time you ask a question, it would be a good idea to link to the raw images (i.e. those with an image extension attached). Additionally, you may want to use Markdown syntax to display the picture inline (see my revision). \$\endgroup\$
    – Daniel
    Jul 5, 2018 at 10:57
  • 1
    \$\begingroup\$ Do you want to keep the empty rows? What do you want the final output to look like? A screenshot of the final output would be helpful. \$\endgroup\$
    – TinMan
    Jul 5, 2018 at 12:01

2 Answers 2

2
\$\begingroup\$

Welcome to Code Review! You've made a very good start at learning VBA and how to put together clean code. Many helpful folks will give you supportive comments and I'll jump in with mine...

Starting with your MergeCells routine:

  1. The name MergeCells is already a method of the Range object. Naming your routine with this same name can be confusing, so I stronly recommend a different name such as MergeAdjacentNonEmptyCellsInColumn. It may seem overly long, but it's descriptive and makes your code an easy read.
  2. You might consider using an array of columns as an input parameter to this Sub. That would give you the flexibility to reuse the Sub in the future on a different set of columns.
  3. I have many bruises and scars from writing code the says Cells(... or Rows.Count without explicitly attaching those references to a specific worksheet. In your case, your Sub will only work on the currently active worksheet. If you create an input parameter for the target worksheet, that will make sure the routine works on the sheet you want for sure. To make it easier to read, just wrap your loop sections in a With clause.
  4. Go ahead and declare your variables closer to their first use. It saves you from having to jump back and forth between their declaration and the executable code.
  5. Please break up long lines such as your Array initialization. It makes it much easier to read. The typical column to wrap a long line is column 80, but you can choose your own as long as you're consistent.
  6. I'm in favor of somewhat longer, more descriptive variable names. It makes your code read more like sentences that can (hopefully) clearly convey what that code is doing. So I use lastRowInColumn and similar names.

So:

Option Explicit

Sub test()
    Dim columnsToMerge() As Variant
    columnsToMerge = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", _
                           "J", "K", "L", "M", "N", "O", "P", "Q", "R", _
                           "S", "T", "U", "AA", "AB", "AC", "AD", "AE", _
                           "AF", "AG", "AH", "AI", "AJ", "AK")

    MergeAdjacentNonEmptyCellsInColumn Sheet1, columnsToMerge
End Sub

Public Sub MergeAdjacentNonEmptyCellsInColumn(ByRef targetWS As Worksheet, _
                                              ByRef colArray() As Variant)
    Application.DisplayAlerts = False
    'Application.ScreenUpdating = false
    With targetWS
        Dim lastRowInColumn As Long
        Dim c As Long
        For c = LBound(colArray) To UBound(colArray)
            lastRowInColumn = .Cells(.rows.count, colArray(c)).End(xlUp).Row
            Dim i As Long
            For i = lastRowInColumn - 1 To 2 Step -1
                If .Cells(i, colArray(c)).value = .Cells(i, colArray(c)).Offset(1, 0).value And _
                   Not IsEmpty(.Cells(i, colArray(c))) Then
                    .Cells(i, colArray(c)).Resize(2, 1).Merge
                    .Cells(i, colArray(c)).HorizontalAlignment = xlCenter
                    .Cells(i, colArray(c)).VerticalAlignment = xlCenter
                End If
            Next i
        Next c
    End With
    Application.DisplayAlerts = True
    'Application.ScreenUpdating = True
End Sub

For your next Sub, you've named it fixMergedCells, but that is identical to the next sub. So I think this sub should be renamed to something like unmergeAndCenter.

  1. A generally followed convention is to begin variable names with lower case and Sub/Function names with an uppercase letter. That would make your sub UnmergeAndCenter.
  2. The variable m is a Range. But as I mentioned earlier, I see a single-letter variable as a looping index. So I'd rather see this named allMergedCells because that's what you get when you perform the Intersect action.

And so:

Sub test1()
    UnmergeAndCenter RawData
End Sub

Sub UnmergeAndCenter(sh As Worksheet)
    'replace merged cells by Center Across Selection
    'high perf version using a hack: https://stackoverflow.com/a/9452164/78522
    Dim constFla As Variant
    constFla = Array(xlConstants, xlFormulas)

    Dim usedArea As Range
    Set usedArea = sh.UsedRange

    Dim i As Long
    For i = 0 To 1                               '1 run for constants, 1 for formulas
        Err.Clear
        On Error Resume Next
        Dim allMergedCells As Range
        Set allMergedCells = Intersect(usedArea.Cells.SpecialCells(constFla(i)), _
                                       usedArea.Cells.SpecialCells(xlBlanks))
        On Error GoTo 0
        If Not allMergedCells Is Nothing Then
            Dim c As Range
            For Each c In allMergedCells.Cells
                If c.MergeCells Then
                    With c.MergeArea
                        'Debug.Print .Address
                        .UnMerge
                        .HorizontalAlignment = xlCenterAcrossSelection
                    End With
                End If
            Next c
        End If
    Next i
End Sub
  1. Capitalize the first letter of your last Sub.
  2. It's another long habit of mine (create your own style and habit) that I almost never write a compound statement (like an If) on one line. It may be tedious, but it makes my code more consistent to always use multiple lines. Makes it easier to maintain in the future (IMHO).

Finally:

Sub FixMergedCells(Optional sh As Variant)
    If IsMissing(sh) Then
        Set sh = ActiveSheet
    End If
    sh.Cells.UnMerge
End Sub
\$\endgroup\$
2
\$\begingroup\$

It appears that you merged the cells to clear the data. Then you unmerge the cells. Why not just clear the data?

Sorry, not much of a review. As the OP mentioned the code was written with considerable help from SO. MergeCells() was authored by Jeeped and fixMergedCells() by Patrick Honorez. They both did a pretty good job.

The code will produce similar output to the OPs in a fraction of the time. It doesn't, however, Center Across Selection.

Sub ClearRepeatData()
    Dim Target As Range
    Dim col As Variant, data() As Variant
    Dim c As Long, r As Long

    With ThisWorkbook.Worksheets("Sheet1")
        Set Target = .Range("A2:AK2", .Cells(.Rows.Count, 1).End(xlUp))
    End With

    data = Target.Value

    For Each col In Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "AA", "AB", "AC", "AD", "AE", "AF", "AG", "AH", "AI", "AJ", "AK")
        c = Cells(1, col).Column
        For r = UBound(data) To 2 Step -1
            If data(r, c) = data(r - 1, c) Then data(r, c) = vbNullString
        Next
    Next

    Target.Value = data

End Sub
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.