VBA. Удаление нескольких ячеек подряд, если одна ячейка пуста - PullRequest
Новая
       39

VBA. Удаление нескольких ячеек подряд, если одна ячейка пуста

0 голосов
/ 19 февраля 2020

У меня есть несколько столбцов в таблице Excel ... скажем A1:D10. Я хочу найти пустые ячейки в столбце C, удалить эту ячейку, а также ячейки A, B и D той же строки, а затем сдвинуть вверх. Но только в диапазоне A1:D10. У меня есть другая информация в этом листе Excel за пределами этого диапазона, которую я хочу сохранить в исходном положении. Поэтому я не могу использовать что-то вроде этого: 

.SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Не могу заставить работать что-то вроде следующего, потому что это смещает только один столбец, а не все четыре столбца. 

Set rng = Range("A1:D10").SpecialCells(xlCellTypeBlanks)
rng.Rows.Delete Shift:=xlShiftUp

Ответы [ 3 ]

0 голосов
/ 19 февраля 2020

Если в столбцах A до D ниже строки 10 данных нет , которые вы не хотите перемещать вверх, то SpecialCells и Delete Shift Up можно использовать следующим образом 

Sub Demo1()
    Dim ws As Worksheet
    Dim TestColumn As Long
    Dim StartColumn As Long
    Dim EndColumn As Long
    Dim FirstRow As Long
    Dim LastRow As Long

    Dim i As Long
    Dim rng As Range, arr As Range

    ' set up reference data
    Set ws = ActiveSheet '<~~ update as required
    TestColumn = 3  'C
    StartColumn = 1 'A
    EndColumn = 4   'D
    FirstRow = 1
    LastRow = 10

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    With ws
        On Error Resume Next
            Set rng = .Range(.Cells(FirstRow, TestColumn), .Cells(LastRow, TestColumn)).SpecialCells(xlCellTypeBlanks)
        On Error GoTo 0

        If Not rng Is Nothing Then
            For Each arr In rng.Areas
                arr.EntireRow.Resize(, EndColumn - StartColumn + 1).Delete Shift:=xlShiftUp
            Next
        End If
    End With
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Если в столбцах A до D ниже строки 10 данные, которые вы не хотите перемещать, - это , то вы можете использовать Cut и Paste вот так 

Sub Demo()
    Dim ws As Worksheet
    Dim TestColumn As Long
    Dim StartColumn As Long
    Dim EndColumn As Long
    Dim FirstRow As Long
    Dim LastRow As Long

    Dim i As Long

    ' set up reference data
    Set ws = ActiveSheet '<~~ update as required
    TestColumn = 3  'C
    StartColumn = 1 'A
    EndColumn = 4   'D
    FirstRow = 1
    LastRow = 10

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    With ws
        If IsEmpty(.Cells(LastRow, TestColumn)) Then
            .Cells(LastRow, StartColumn).Resize(1, EndColumn - StartColumn + 1).Clear
        End If
        For i = LastRow - 1 To FirstRow Step -1
            If IsEmpty(.Cells(i, TestColumn)) Then
                .Range(.Cells(i + 1, StartColumn), .Cells(LastRow, EndColumn)).Cut .Cells(i, StartColumn)
            End If
        Next
    End With
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
0 голосов
/ 19 февраля 2020

Использование метода Variant Array 

Sub test2()
    Dim rngDB As Range, vDB As Variant
    Dim i As Integer, j As Integer, n As Integer
    Dim k As Integer

    Set rngDB = Range("a1:d10")

    vDB = rngDB

    n = UBound(vDB, 1)
    For i = 1 To n
        If IsEmpty(vDB(i, 3)) Then
            For j = 1 To 4
                If j <> 3 Then
                    vDB(i, j) = Empty
                End If
            Next j
        End If
    Next i
    For j = 1 To 4
        If j <> 3 Then
            For i = 1 To n - 1
                For k = i To n - 1
                    If vDB(k, j) = Empty Then
                        vDB(k, j) = vDB(k + 1, j)
                        vDB(k + 1, j) = Empty
                    End If
                Next k
            Next i
        End If
    Next j
    rngDB = vDB
End Sub
0 голосов
/ 19 февраля 2020

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

Sub deleteEmptyRow()
Dim i As Integer

    For i = 1 To 10
        If Cells(i, 3) = "" Then
            Range(Cells(i, 1), Cells(i, 4)).delete Shift:=xlUp
        End If
    Next i

End Sub
...