Question

注意到一些类似的问题，所以我很抱歉这似乎是重复 - 但鉴于我对VBA的理解不足，我无法修改以前的建议以满足我的需求。

我有两个标签，称为“Raw X”和“X”。我想要实现的是：

如果“Raw X”中的N列= 4，则不要复制它。
如果“Raw X”中的列N＆lt;＆gt; 4，然后需要复制到“X”

棘手的部分（我认为）是我不想要整行，只需要某些细胞。因此，从“Raw X”开始，需要将单元C，D，E，K，L和M分别复制到“X”单元H，I，K，L，M和N中。

我正在使用并尝试修改的VBA如下所示，但是一旦它只需要复制某些单元格，它就变得太复杂了。

Sub RoundedRectangle5_Click()
Dim tfCol As Range, Cell As Object 

Set tfCol = Range("N2:N1000") 

For Each Cell In tfCol 

    If IsEmpty(Cell) Then 
        Exit Sub 
    End If 

    If Cell.Value <> "4" Then 
        Cell.EntireRow.Copy 
        Sheets."X".Select 
        ActiveSheet.Range("A65536").End(xlUp).Select 
        Selection.Offset(2, 0).Select 
        ActiveSheet.Paste 
    End If 

Next 

End Sub

Answer 1

Sub RoundedRectangle5_Click()
Dim tfCol As Range, _
    Cell As Range, _
    wsRawX As Worksheet, _
    wsX As Worksheet, _
    CellVal As String

With ThisWorkbook
    Set wsRawX = .Sheets("Raw X")
    Set wsX = .Sheets("X")
End With 'ThisWorkbook
Set tfCol = wsRawX.Range("N2:N1000")

For Each Cell In tfCol
    If IsEmpty(Cell) Then Exit Sub

    If IsError(Cell.value) Then
        CopyData wsRawX, Cell.Row, wsX
    Else
        If CStr(Cell.value) <> "4" Then
            CopyData wsRawX, Cell.Row, wsX
        Else
        End If
    End If
Next Cell
End Sub

Sub CopyData(SrcSheet As Worksheet, ByVal SrcRow As Double, DestSheet As Worksheet)
    Dim NextRow As Double
    NextRow = DestSheet.Range("H" & DestSheet.Rows.Count).End(xlUp).Row + 2
    With SrcSheet
        'C and D to H and I
        .Range("C" & SrcRow & ":D" & SrcRow).Copy DestSheet.Range("H" & NextRow)
        'E to K
        .Cells(SrcRow, "E").Copy DestSheet.Range("K" & NextRow)
        'K, L and M to L, M and N
        .Range("K" & SrcRow & ":M" & SrcRow).Copy DestSheet.Range("L" & NextRow)
    End With 'wsRawX
End Sub

VBA - 复制给定的特定单元符合条件

1 个答案: