Check merged cell and compare adjacent to set unique value from compared cells values

问题

I'm writing a macro in Excel 2010 for a problem that is as follows:
I have two columns, one with a Key string value and one with a uuid. The idea is that every key should have only one uuid but as the table is now, key cell could be merged cells or single cells. The macro needs to recognize which cells are merged and which are not, so, I have two options:

If cell is merged, check all its adjacent cells, pick first uuid value and copy/paste it to other adjacent cells, that is to say, cell below(Could be with an Offset())
If cell is not merged , but key value is repeated in multiple cells, copy/paste uuid value to adjacent cells.

So basically is to check merged cells MergeArea but I don't know if I need to iterate through its addresses or check cells in the range with an offset of Offset(0,1) or what. With my code I can know if the cells are merged but now, how con I iterate through it's adjacent cells values?

Code as is now:

Sub CopyUUID()
Dim lRow As Long
Dim rng As Range
Dim ws As Worksheet
Dim rMerged As Range
Dim value As Variant

Set ws = Sheets(ActiveSheet.Name)

On Error GoTo ExitProgram 'If an error happens within the execution, skips it and continue in next step
Application.DisplayAlerts = False 'We can cancel the procedure without errors

With ws
    lRow = .Range("F" & .Rows.count).End(xlUp).row
    Set rng = .Range(.Cells(3, 6), .Cells(lRow, 6))
    rng.Select
    For Each cell In rng
        If cell.MergeCells Then
            'Code for merged cells
        Else
            'Code to use for single cells
        End If
    Next cell
End With
ExitProgram:
   Exit Sub
End Sub

回答1:

Try the following code. Note that this is going to overwrite the current contents of UUID, so make a backup copy before testing. If you don't want the UUID column modified, you can modify this to suit your needs.

Sub CopyUUID()
    Dim lRow As Long
    Dim rng As Range
    Dim c As Range
    Dim ws As Worksheet
    Dim rMerged As Range
    Dim value As Variant

    Set ws = Sheets(ActiveSheet.Name)

    On Error GoTo ExitProgram 'If an error happens within the execution, skips it and continue in next step
    ' Application.DisplayAlerts = False 'We can cancel the procedure without errors

    With ws
        lRow = .Range("F" & .Rows.Count).End(xlUp).Row
        Set rng = .Range(.Cells(3, 6), .Cells(lRow, 6))
        ' rng.Select
        For Each c In rng

            If c.MergeCells Then
                'Code for merged cells
                c.Offset(0, 1).Formula = c.MergeArea.Cells(1, 1).Offset(0, 1).Formula
            Else
                'Code to use for single cells
                If c.Formula = c.Offset(-1, 0).Formula Then
                    c.Offset(0, 1).Formula = c.Offset(-1, 1).Formula
                End If
            End If
        Next c
    End With
    ExitProgram:
       Exit Sub
End Sub

When in a MergedCell, it makes the UUID the same as the UUID of the first cell in the merged area. When not in a MergedCell, it copies UUID from the row above if Key is the same as the row above.

I changed your variable cell to c (I don't like to use variable names that can be confused with built-ins) and commented out a couple of lines.

Hope this helps

回答2:

Option Explicit

Sub CopyUUID()

    Const UUID As Long = 31 'col AE

    Dim lRow As Long, cel As Range, isM As Boolean, copyID As Boolean, kCol As Long

    With ActiveSheet
        kCol = -25          'col F
        lRow = .Cells(.Rows.Count, UUID + kCol).End(xlUp).Row

        For Each cel In .Range(.Cells(3, UUID), .Cells(lRow, UUID))

            isM = cel.Offset(0, kCol).MergeCells
            copyID = isM And Len(cel.Offset(0, kCol)) = 0
            copyID = copyID Or (Not isM And cel.Offset(0, kCol) = cel.Offset(-1, kCol))

            If copyID Then cel = cel.Offset(-1)
        Next
    End With
End Sub

回答3:

I adopt a simple approach to this problem as illustrated through steps taken by me.

sample sheet showing data with merged cells and unmerged cells.
Run the program code to unmerge the cells. Output of the program is appended below.

If this structure of data matches your case then addition of 2 lines of code for column B will leave the data as per following image.

Program code is as follows:

'Without column deletion:

Sub UnMergeRanges()
    Dim cl As Range
    Dim rMerged As Range
    Dim v As Variant

    For Each cl In ActiveSheet.UsedRange
        If cl.MergeCells Then
            Set rMerged = cl.MergeArea
            v = rMerged.Cells(1, 1)
            rMerged.MergeCells = False
            rMerged = v
        End If
    Next
End Sub
'With coumn deletion   
Sub UnMergeRangesB()
    Dim cl As Range
    Dim rMerged As Range
    Dim v As Variant

    For Each cl In ActiveSheet.UsedRange
        If cl.MergeCells Then
            Set rMerged = cl.MergeArea
            v = rMerged.Cells(1, 1)
            rMerged.MergeCells = False
            rMerged = v
        End If
    Next
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
End Sub

来源：https://stackoverflow.com/questions/32465349/check-merged-cell-and-compare-adjacent-to-set-unique-value-from-compared-cells-v

标签

excel

vba

excel-vba

cells