Диапазон слияния ячеек смещен к цели

Question

У меня есть лист, на котором текст заметки Appt очень длинный. Мне нужно поместить его в ряд из девяти объединенных ячеек.

Я пытаюсь проверить все ячейки в столбце A на значение «Appt Note:», затем объединить девять ячеек справа от него так, все мои данные отображаются в видимом формате.

Я проверил много сообщений в Интернете, но не могу собрать свой конкретный код. Я построил его, за исключением слияния.

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

Answer 1

Согласно моему комментарию, настоящим образец Range.Find, где в этом случае я предполагаю, что "Appt Note:" существует только один раз на листе:

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

Примечание: Объединенные ячейки Худший кошмар VBA! Старайтесь держаться от них подальше. Может быть, вы можете допустить переполнение текста?

---

Редактировать: Если ваше значение может существовать несколько раз, используйте 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

Answer 2

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 относится к книге, в которой находится код VBA, чтобы избежать проблем, когда активна другая книга. Оператор Like можно использовать для проверки соответствия значения ячейки шаблону подстановочного знака.
cell.Resize(1, 9) можно использовать для получения нового диапазона, начинающегося с cell и размера до 9 столбцов.

Answer 3

Я нашел код, который будет делать то, что мне нужно. См. ниже. Я проверил это, и это работает. Он начнется внизу моей электронной таблицы и найдет последнюю строку с данными и будет работать до тех пор, пока не достигнет моей первой строки.

Большое спасибо за вашу помощь! Если у вас есть какие-либо предложения, советы, предупреждения и т. Д. c относительно кода ниже, пожалуйста, поделитесь. Как я уже сказал, я совершенно новичок в VB и знаю достаточно, чтобы быть опасным. Поэтому я могу использовать всю помощь, которую могу получить. :)

 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