Как объединить ячейки в Excel с VBA с сотнями наборов данных

Question

Исходные данные выглядят следующим образом введите описание изображения здесь

Я хочу сделать приведенный ниже код VBA, чтобы копировать сотни раз для сотен наборов данных

`Sub mergeCellsAndCenter ()

   With Worksheets("Sheet1").Range("C5:C6")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Merge
     End With

     With Worksheets("Sheet1").Range("D5:D6")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Merge
     End With

     With Worksheets("Sheet1").Range("E5:E6")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Merge
     End With


    With Worksheets("Sheet1").Range("C7:C8")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Merge
     End With

     With Worksheets("Sheet1").Range("D7:D8")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Merge
     End With

     With Worksheets("Sheet1").Range("E7:E8")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Merge
     End With

     With Worksheets("Sheet1").Range("C9:C10")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Merge 
     End With

     With Worksheets("Sheet1").Range("D9:D10")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Merge
     End With

     With Worksheets("Sheet1").Range("E9:E10")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Merge
     End With

End Sub` Когда я запускаю этот макрос, он работает для 10 строк. Я хочу, чтобы он работал для сотен строк без необходимости вводить каждый код набора. "

Answer 1

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

Public Sub DeleteBlankRows()
    Dim SourceRange As Range
    Dim EntireRow As Range

    Set SourceRange = Application.Selection

    If Not (SourceRange Is Nothing) Then
        Application.ScreenUpdating = False

        For I = SourceRange.Rows.Count To 1 Step -1
            Set EntireRow = SourceRange.Cells(I, 1).EntireRow
            If Application.WorksheetFunction.CountA(EntireRow) = 0 Then
                EntireRow.Delete
            End If
        Next

        Application.ScreenUpdating = True
    End If
End Sub

Answer 2

Код работает. Большое спасибо.

@ A SH, спасибо за ваш вклад, хотя это был не запрос.

Объединение ячеек с пустыми ячейками под каждой строкой просто применяется к столбцам B – E и начинается со строки № 05 и заканчивается до sh ячеек со значениями. Столбцы F – H будут содержать раскрывающийся список (строки 5 и 6) со значениями, относящимися к набору данных в столбце B до C, а также проиллюстрирован Urdearboy.

Еще раз спасибо всем.

Answer 3

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

L oop через ваши строки (с интервалом 2) и объедините ваши значения для каждого из ваших 3 столбцов в отдельности. Также лучше подождать, чтобы отформатировать ваши ячейки, пока ваш l oop не будет готов. Нет необходимости повторять ту же операцию внутри l oop, , которая может занять много времени , когда вы можете отформатировать весь диапазон сразу, когда вы закончите с l oop.

---

Sub Shelter_In_Place()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lr As Long

lr = ws.Range("C" & ws.Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False

    For i = 5 To lr Step 2
        ws.Range("C" & i).Resize(2).Merge
        ws.Range("D" & i).Resize(2).Merge
        ws.Range("E" & i).Resize(2).Merge
    Next i

    With ws.Range("C5:E" & lr)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With

Application.ScreenUpdationg = True

End Sub