Скопируйте диапазон ячеек и выберите только ячейки с данными

Question

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

В моем листе Excel у меня есть данные, работающие с A1-A18, B пусти C1-C2.Теперь я хотел бы скопировать все ячейки, которые содержат значение.

 With Range("A1")
     Range(.Cells(1, 1), .End(xlDown).Cells(50, 3)).Copy
 End With

Это скопирует все из A1-C50, но я хочу, чтобы только A1-A18 и C1-C2 копировались, если они содержат данные.Но это должно быть сформировано так, чтобы, как только у меня были данные в B или мой диапазон расширялся, чтобы они тоже копировались., Текущий код:

Sub test()

Dim i As Integer
Sheets("Sheet1").Select
i = 1

With Range("A1")
   If .Cells(1, 1).Value = "" Then
   Else
     Range(.Cells(1, 1), .End(xlDown)).Copy Destination:=Sheets("Sheet2").Range("A" & i)
     x = x + 1
   End If
End With

Sheets("Sheet1").Select

x = 1
With Range("B1")
' Column B may be empty. If so, xlDown will return cell C65536
' and whole empty column will be copied... prevent this.
    If .Cells(1, 1).Value = "" Then
       'Nothing in this column.
       'Do nothing.
    Else
       Range(.Cells(1, 1), .End(xlDown)).Copy Destination:=Sheets("Sheet2").Range("B" & i)
       x = x + 1
    End If
End With

Sheets("Sheet1").Select

x = 1
With Range("C1")
    If .Cells(1, 1).Value = "" Then
    Else
        Range(.Cells(1, 1), .End(xlDown)).Copy Destination:=Sheets("Sheet2").Range("C" & i)
        x = x + 1
    End If
End With

End Sub

A1 - A5 содержит данные, A6 - бланк, A7 - данные.Он останавливается на A6 и направляется к столбцу B и продолжает в том же духе.

Answer 1

Поскольку ваши три столбца имеют разные размеры, самое безопасное - скопировать их один за другим.Любые ярлыки в стиле PasteSpecial, вероятно, будут вызывать головную боль.

With Range("A1")
    Range(.Cells(1, 1), .End(xlDown)).Copy myDestinationRangeA
End With

With Range("B1")
    ' Column B may be empty. If so, xlDown will return cell C65536
    ' and whole empty column will be copied... prevent this.
    If .Cells(1, 1).Value = "" Then
        'Nothing in this column.
        'Do nothing.
    Else
        Range(.Cells(1, 1), .End(xlDown)).Copy myDestinationRangeB
    EndIf
End With

With Range("C1")
    Range(.Cells(1, 1), .End(xlDown)).Copy myDestinationRangeC
End With

Теперь это уродливо, и более понятным вариантом будет цикл по столбцам, особенно если у вас много столбцов, и вы вставляете их в соседние столбцы в том же порядке.

Sub CopyStuff()

    Dim iCol As Long

    ' Loop through columns
    For iCol = 1 To 3 ' or however many columns you have
        With Worksheets("Sheet1").Columns(iCol)
            ' Check that column is not empty.
            If .Cells(1, 1).Value = "" Then
                'Nothing in this column.
                'Do nothing.
            Else
                ' Copy the column to the destination
                Range(.Cells(1, 1), .End(xlDown)).Copy _
                    Destination:=Worksheets("Sheet2").Columns(iCol).Cells(1, 1)
            End If
        End With
    Next iCol

End Sub

---

РЕДАКТИРОВАТЬ Итак, вы изменили свой вопрос ... Попробуйте пройтись по отдельным ячейкам, проверить, пуста ли текущая ячейка, и если нет, скопировать ее.Не проверял это, но вы поняли:

    iMaxRow = 5000 ' or whatever the max is. 
    'Don't make too large because this will slow down your code.

    ' Loop through columns and rows
    For iCol = 1 To 3 ' or however many columns you have
        For iRow = 1 To iMaxRow 

        With Worksheets("Sheet1").Cells(iRow,iCol)
            ' Check that cell is not empty.
            If .Value = "" Then
                'Nothing in this cell.
                'Do nothing.
            Else
                ' Copy the cell to the destination
                .Copy Destination:=Worksheets("Sheet2").cells(iRow,iCol)
            End If
        End With

        Next iRow
    Next iCol

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

Answer 2

Взгляните на специальную функцию вставки.Есть свойство «пропустить пустое», которое может вам помочь.

Answer 3

Чтобы улучшить ответ Жана-Франсуа Корбетта, используйте .UsedRange.Rows.Count, чтобы получить последний использованный ряд.Это даст вам достаточно точный диапазон и не остановится на первой пустой ячейке.

Вот ссылка на отличный пример с комментариями для начинающих ...

• Макрос Excel - вставка только непустых ячеек с одного листа на другой - Переполнение стека