excel 带条件复制和粘贴

hxzsmxv2 于 2023-05-19 发布在其他

关注(0)|答案(2)|浏览(218)

我期待复制和粘贴某些行，如果条件得到满足。如果单元格为空，则跳到下一行。
下面的代码没有跳过空白单元格，而是将Sheet 1中的所有内容复制并粘贴到DataTable工作表。不确定为什么If Status <>“”未过滤掉空白。

Sub copypaste()
Dim Cell As Range
Dim CellCol As Range
Dim PasteCell As Range
Dim PasteCellAmount As Range
Dim DataTable As Worksheet

Set DataTable = Worksheets("Data")
Set CellCol = Sheet1.Range("C2:C50")

For Each Cell In CellCol
    'paste cells into blank row
    If DataTable.Range("A2") = "" Then
       Set PasteCell = DataTable.Range("A2")
       Set PasteCellAmount = DataTable.Range("C2")
    Else
       Set PasteCell = DataTable.Range("A2").Offset(1, 0)
       Set PasteCellAmount = DataTable.Range("C2").Offset(1, 0)
    End If
    
    'copy cell in Column A and C in the row with value
    If Cell <> "" Then 
    CellCol.Offset(0, -2).Copy PasteCell
    CellCol.Offset(0, 0).Copy PasteCellAmount
    
    Next cell

End sub

excel

来源：https://stackoverflow.com/questions/76199791/copy-and-paste-with-conditions

2条答案

按热度按时间

ilmyapht1#

**（1）**你的代码缺少一个End If语句（关闭最后一个If），所以它不会编译。
**（2）**在写入CellCol.Offset(0, -2)时，您将始终复制整个CellCol-Range（“C2：C50”）。换句话说：如果至少有一个单元格不为空，则复制整个区域。如果30个单元格不为空，则该区域将复制30次，但这没有什么区别。

你（可能，我不知道你的确切逻辑）需要做的是使用cell：

cell.Offset(0, -2).Copy PasteCell
cell.Offset(0, 0).Copy PasteCellAmount

**（3）**永远不会更改目标单元格。在第一次复制之后，您将不得不移动到下一行（否则每个复制命令都将覆盖前一行）。举个例子

cell.Offset(0, -2).Copy PasteCell
cell.Offset(0, 0).Copy PasteCellAmount
Set PasteCell = PasteCell.Offset(1, 0)
Set PasteCellAmount = PasteCellAmount.Offset(1, 0)

赞(0）回复(0）举报 2023-05-19

xxslljrj2#

有条件复制

Option Explicit

Sub CopyConditionally()

    ' s - Source
    ' d - Destination
    ' l - Lookup
    ' v - Value
    
    Dim sws As Worksheet: Set sws = Sheet1 ' code name
    Dim slrg As Range: Set slrg = sws.Range("C2:C50")
    Dim svrg As Range: Set svrg = slrg.EntireRow.Columns("A") ' 'A2:A50'
    
    Dim dws As Worksheet: Set dws = ThisWorkbook.Sheets("Data") ' (tab) name
    Dim dlCell As Range: Set dlCell = dws.Range("C2")
    Dim dvCell As Range: Set dvCell = dlCell.EntireRow.Columns("A") ' 'A2'
    
    Dim slCell As Range, svCell As Range, sr As Long
    
    For Each slCell In slrg.Cells ' reference the current lookup cell
        sr = sr + 1 ' used to reference the current value cell
        If Len(CStr(slCell.Value)) > 0 Then ' is not blank
            Set svCell = svrg.Cells(sr) ' reference the value cell
            ' Write to the current destination cells.
            dlCell.Value = slCell.Value
            dvCell.Value = svCell.Value
            ' Reference the next destination cells (the ones below).
            Set dlCell = dlCell.Offset(1)
            Set dvCell = dvCell.Offset(1)
        'Else ' is blank; do nothing
        End If
    Next slCell

End Sub

赞(0）回复(0）举报 2023-05-19

我来回答

excel 带条件复制和粘贴

2条答案

有条件复制

相关问题

热门标签

最新问答