遍历一行并将单元格合并为标题vba

Question

This is an addition to my question yesterday so I am starting a new question. Basically I get different ranges of data on a sheet in excel and data range vary each week so last used column and last used row vary.

I would like to merge row 3 and 4 based on names and I will post a sample data so you can understand what I am trying to achieve. Row 3 is the one that has the names and row 4 is always empty. Right now, I am getting error 91, Object variable or With block variable not set on Loop While that line.

And again, I am only showing you 3 ranges since it is best fit on the picture.

Sub test()

'Set Up

Dim f, g, h, i, j, k As Range
Dim firstaddress As String
Dim ws1 As Worksheet



Set ws1 = Sheets("Sheet1")




'Merge back
With ws1.Rows(3)
    Set f = .Find("A", LookIn:=xlValues)
    If Not f Is Nothing Then
        firstaddress = f.Address
        Do
           Range(f.Resize(2), f.Resize(, 1)).Merge
           Range(f.Resize(2), f.End(xlToRight)).BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
           Set f = .FindNext(f)

        Loop While Not f Is Nothing And f.Address <> firstaddress
    End If
End With

With ws1.Rows(3)
    Set g = .Find("B", LookIn:=xlValues)
    If Not g Is Nothing Then
        firstaddress = g.Address
        Do
           Range(g.Resize(2), g.Resize(, 1)).Merge
           Range(g.Resize(2), g.End(xlToRight)).BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
            Set g = .FindNext(g)
        Loop While Not g Is Nothing And g.Address <> firstaddress
    End If
End With


With ws1.Rows(3)
    Set h = .Find("C", LookIn:=xlValues)
    If Not h Is Nothing Then
        firstaddress = h.Address
        Do
           Range(h.Resize(2), h.Resize(, 1)).Merge
           Range(h.Resize(2), h.End(xlToRight)).BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
            Set g = .FindNext(h)
        Loop While Not h Is Nothing And h.Address <> firstaddress
    End If
End With


With ws1.Rows(3)
    Set i = .Find("D", LookIn:=xlValues)
    If Not i Is Nothing Then
        firstaddress = i.Address
        Do
           Range(i.Resize(2), i.Resize(, 1)).Merge
            Set i = .FindNext(i)
        Loop While Not i Is Nothing And i.Address <> firstaddress
    End If
End With

With ws1.Rows(3)
    Set j = .Find("E", LookIn:=xlValues)
    If Not j Is Nothing Then
        firstaddress = j.Address
        Do
           Range(j.Resize(2), j.Resize(, 1)).Merge
           Range(j.Resize(2), j.End(xlToRight)).BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
            Set j = .FindNext(j)
        Loop While Not j Is Nothing And j.Address <> firstaddress
    End If
End With


With ws1.Rows(3)
    Set k = .Find("F", LookIn:=xlValues)
    If Not k Is Nothing Then
        firstaddress = k.Address
        Do
           Range(k.Resize(2), k.Resize(, 1)).Merge
            Set k = .FindNext(k)
        Loop While Not k Is Nothing And k.Address <> firstaddress
    End If
End With


End Sub

Answer 1

Can you try this. I think you can shorten your code with a loop. The error I think is caused by the merging of cells which screws up the Find. Merged cells are a bad idea for many reasons.

Sub test()

'Set Up
Dim f As Range
Dim firstaddress As String
Dim ws1 As Worksheet
Dim v, i As Long

Set ws1 = Sheets("Sheet1")
v = Array("A", "B", "C", "D")

'Merge back
For i = LBound(v) To UBound(v)
    With ws1.Rows(3)
        Set f = .Find(v(i), LookIn:=xlValues)
        If Not f Is Nothing Then
            firstaddress = f.Address
            Do
                f.Resize(2).Merge
                Range(f.Resize(2), f.End(xlToRight)).BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
                Set f = .FindNext(f)
            Loop While Not f Is Nothing
        End If
    End With
Next i

End Sub

Answer 2

A loop from ASCII character 65 (eg A) through ASCII character 90 (eg Z) should clean up your code.

Option Explicit

Sub Macro1()
    Dim c As Long, firstaddress As String, f As Range, ffs As Range

    With Worksheets("sheet1").Rows(3).Cells
        .Resize(2, .Columns.Count).UnMerge
        Set f = Nothing
        For c = 65 To 90
            Set f = .Find(Chr(c), LookIn:=xlValues, Lookat:=xlWhole)
            If Not f Is Nothing Then
                Set ffs = f
                firstaddress = f.Address
                Do
                    Set ffs = Union(f, ffs)
                    Set f = .FindNext(after:=f)
                Loop While f.Address <> firstaddress
                With Union(ffs, ffs.Offset(1))
                    .Merge
                    .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
                End With
            End If
        Next c
    End With
End Sub