loop through a row and merge cells as header vba - 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 (e.g. A) through ASCII character 90 (e.g. 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