vba 复制一系列单元格并仅选择包含数据的单元格

Copy a range of cells and only select cells with data

提问by CustomX

I'm looking for a way to copy a range of cells, but to only copy the cells that contain a value.

我正在寻找一种复制一系列单元格的方法，但只复制包含值的单元格。

In my excel sheet I have data running from A1-A18, B is empty and C1-C2. Now I would like to copy all the cells that contain a value.

在我的 excel 表中，我有从 A1-A18 运行的数据，B 为空，C1-C2。现在我想复制所有包含值的单元格。

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

This will copy everything from A1-C50, but I only want A1-A18 and C1-C2 to be copied seen as though these contain data. But it needs to be formed in a way that once I have data in B or my range extends, that these get copied too.

这将复制 A1-C50 中的所有内容，但我只希望复制 A1-A18 和 C1-C2，就像它们包含数据一样。但是它需要以一种方式形成，一旦我在 B 中有数据或我的范围扩展，这些数据也会被复制。

'So the range could be 5000 and it only selects the data with a value.
With Range("A1")
Range(.Cells(1, 1), .End(xlDown).Cells(5000, 3)).Copy
End With

Thanks!

谢谢！

---

---

Thanks to Jean, Current code:

感谢让，当前代码：

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 contains data, A6 is blanc, A7 contains data. It stops at A6 and heads over to column B, and continues in the same way.

A1 - A5 包含数据，A6 为空白，A7 包含数据。它在 A6 处停止并转到 B 列，并以同样的方式继续。

采纳答案by Jean-Fran?ois Corbett

Since your three columns have different sizes, the safest thing to do is to copy them one by one. Any shortcuts à la PasteSpecial will probably end up causing you headaches.

由于您的三列具有不同的大小，因此最安全的做法是将它们一一复制。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

Now this is ugly, and a cleaner option would be to loop through the columns, especially if you have many columns and you're pasting them to adjacent columns in the same order.

现在这很丑陋，一个更简洁的选择是遍历列，特别是如果您有很多列并且您以相同的顺序将它们粘贴到相邻的列。

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

---

---

EDIT So you've changed your question... Try looping through the individual cells, checking if the current cell is empty, and if not copy it. Haven't tested this, but you get the idea:

编辑 所以你已经改变了你的问题......尝试遍历单个单元格，检查当前单元格是否为空，如果不复制它。还没有测试过这个，但你明白了：

    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

This code will be really slow if iMaxRowis large. My hunch is that you're trying to solve a problem in a sort of inefficient way... It's a bit hard to settle on an optimal strategy when the question keeps changing.

如果iMaxRow很大，这段代码会很慢。我的预感是，您正试图以一种低效的方式解决问题……当问题不断变化时，确定最佳策略有点困难。

回答by Tiago Cardoso

Take a look at the paste Special function. There's a 'skip blank' property that may help you.

看看粘贴特殊功能。有一个“跳过空白”属性可以帮助你。

回答by Lopsided

To improve upon Jean-Francois Corbett's answer, use .UsedRange.Rows.Count to get the last used row. This will give you a fairly accurate range and it will not stop at the first blank cell.

要改进 Jean-Francois Corbett 的答案，请使用 .UsedRange.Rows.Count 获取最后使用的行。这将为您提供相当准确的范围，并且不会在第一个空白单元格处停止。

Here is a link to an excellent example with commented notes for beginners...

这是一个优秀示例的链接，其中包含针对初学者的注释注释...

• Excel macro - paste only non empty cells from one sheet to another - Stack Overflow

• Excel宏 - 仅将非空单元格从一张纸粘贴到另一张纸上 - VoidCC