CODEWITHSUNDEEP
excelvba
LRodrigu
LRodrigu

Reputation: 15

Merge range of cells offset to target

I have a worksheet where Appt Note text is very lengthy. I need to place it in a row of nine merged cells.

I'm trying to check all the cells in column A for the value "Appt Note:" then merge the nine cells to the right of it so all my data shows up in a viewable format.

I checked lots of posts online but can't put my particular code together. I've built it, with the exception of the merge.

Sub MergeTest()
Dim cel As Range
Dim WS As Worksheet

For Each WS In Worksheets
    For Each cel In WS.Range("$A1:$A15")
        If InStr(1, cel.Value, "Appt Note:") > 0 Then Range(cel.Offset(1, 9)).Merge
    Next
Next
End Sub

Upvotes: 1

Views: 817

Answers (3)

Slai
Slai

Reputation: 22896

Sub MergeTest()
    Dim ws As Worksheet, cell As Range

    For Each ws In ThisWorkbook.Worksheets
        For Each cell In ws.Range("A1:A15")
            If cell.Value Like "Appt Note:*" Then cell.Resize(1, 9).Merge
        Next
    Next
End Sub

ThisWorkbook refers to the workbook where the VBA code is, to avoid issues when a different workbook is active. The Like operator can be used to check if the cell value matches a wildcard pattern.
cell.Resize(1, 9) can be used to get a new range starting from cell and resized to 9 columns.

Upvotes: 1

JvdV
JvdV

Reputation: 75990

As per my comment, hereby a sample of Range.Find where in this case I assume "Appt Note:" only exists once per sheet:

Sub Test()

Dim ws As Worksheet
Dim cl As Range

For Each ws In ThisWorkbook.Worksheets
    Set cl = ws.Range("A:A").Find(What:="Appt Note:", Lookat:=xlPart)
    If Not cl Is Nothing Then
        cl.Offset(0, 1).Resize(1, 9).Merge
    End If
Next

End Sub

Note: Merged cells are VBA's worst nightmare! Try to stay away from them. Maybe you can let the text just overflow?

Edit: In case your value could exist multiple times, use Range.FindNext:

Sub Test()

Dim ws As Worksheet
Dim cl As Range
Dim rw As Long

For Each ws In ThisWorkbook.Worksheets
    Set cl = ws.Range("A:A").Find(What:="Appt Note:", Lookat:=xlPart)
    If Not cl Is Nothing Then
        rw = cl.Row
        Do
            cl.Offset(0, 1).Resize(1, 9).Merge
            Set cl = ws.Range("A:A").FindNext(cl)
        If cl Is Nothing Then
            GoTo DoneFinding
        End If
        Loop While cl.Row <> rw
    End If
DoneFinding:
Next

End Sub

Upvotes: 2

LRodrigu
LRodrigu

Reputation: 15

I found code that will do what I need. See below. I've tested it and it works. It will start at the bottom of my spreadsheet and find the last row with data and work it's way up until it reaches my first row.

Thanks so much for all your help! If you have any suggestions, advice, warnings, etc regarding the code below, please share. As I said, I am completely new to VB and know just enough to be dangerous. So I can use all the help I can get. :)

 Sub mergeCellsBasedOnCriteria()
Dim myFirstRow As Long
Dim myLastRow As Long
Dim myCriteriaColumn As Long
Dim myFirstColumn As Long
Dim myLastColumn As Long
Dim myWorksheet As Worksheet
Dim myCriteria As String
Dim iCounter As Long

myFirstRow = 1
myCriteriaColumn = 1
myFirstColumn = 2
myLastColumn = 10
myCriteria = "Appt Note:"

Set myWorksheet = Worksheets("Sample")

With myWorksheet

    myLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For iCounter = myLastRow To myFirstRow Step -1
        If .Cells(iCounter, myCriteriaColumn).Value = myCriteria Then
            .Range(.Cells(iCounter, myFirstColumn), .Cells(iCounter, myLastColumn)).Merge
            .Range(.Cells(iCounter, myFirstColumn), .Cells(iCounter, myLastColumn)).WrapText = True

        End If
    Next iCounter

End With

End Sub

Upvotes: 0

Related Questions