Как скопировать диапазон, игнорируя строки, в которых значение в столбце 2 пустое

Question

Я использую макрос кнопки для копирования диапазона, это очень просто:

Worksheets("SNOW").Range("C6:D18").Copy

Теперь, как бы я изменил это так: «Скопируйте этот диапазон, но если значение в столбце D пустое, полностью пропустите эту строку в процессе копирования»? Работа с текстом, а не числами.

Спасибо.

Answer 1

Вы можете скопировать каждую область отдельно.

Option Explicit
Sub foo()
    Dim ws As Worksheet, r As Range, rCpy As Range
    Dim rDest As Range

Set ws = Worksheets("SNOW")
With ws
    Set r = .Range(.Cells(6, 4), .Cells(18, 4)).SpecialCells(xlCellTypeConstants)
    Set rDest = .Cells(6, 10)

    For Each rCpy In r.Areas
        Set rCpy = rCpy.Offset(columnoffset:=-1).Resize(columnsize:=2)
        rCpy.Copy rDest
        Set rDest = rDest.Offset(rCpy.Rows.Count)
    Next rCpy
End With

End Sub

Еще один метод, который будет работать независимо от содержимого исходных данных:

Set ws = Worksheets("SNOW")
With ws
    .Rows.Hidden = False
    Set rDest = .Cells(1, 6)
    Set r = .Range(.Cells(6, 4), .Cells(18, 4)).SpecialCells(xlCellTypeBlanks)
    r.EntireRow.Hidden = True
    Set r = .Range(.Cells(6, 3), .Cells(18, 4)).SpecialCells(xlCellTypeVisible)
    .Rows.Hidden = False
    r.Copy rDest
End With

Answer 2

Вы можете фильтровать и копировать отфильтрованные данные:

Sub Copy_Filtered()

    With ThisWorkbook.Worksheets("Snow")
        If .FilterMode Then
            .ShowAllData
        End If

        With .Range("A6:D18")
            .AutoFilter Field:=4, Criteria1:="<>"
            .Copy 'Destination:=ThisWorkbook.Worksheets("Blizzard").Range("A1")
        End With

    End With

End Sub

Примечание: Раскомментируйте пункт назначения, чтобы вставить диапазон в лист Blizzard.

Answer 3

Вам придется использовать Union, чтобы создать диапазон, содержащий только выбранные вами строки (если значение в столбце D не пустое):

Sub Test()

Dim rng As Range, i As Long

For i = 6 To 18
    If Range("D" & i).Value <> "" Then
        If rng Is Nothing Then
            Set rng = Range("C" & i & ":D" & i)
        Else
            Set rng = Application.Union(rng, Range("C" & i & ":D" & i))
        End If
    End If
Next i

If Not rng Is Nothing Then
    rng.Copy
End If

End Sub