Question

我正在尝试使命令按钮根据是否满足要求将数据从“全部”主表复制到4个不同的表中。我已使用以下代码使它与我的“借阅”一起使用，但是在接下来的3列中，我具有数据“ FX”，“帐户”和“付款”，并且我希望此命令按钮可与所有床单。一些dato点将分成多张，而有些则最多只能容纳其中1张。有谁知道我如何扩展代码使其工作？

Private Sub CommandButton1_Click()

Dim AllSheet As Worksheet
Dim LendSheet As Worksheet
Dim LastRow As Integer
Dim RowCnt As Integer
Dim DestRow As Integer

Set AllSheet = ActiveWorkbook.Sheets("All")
Set LendSheet = ActiveWorkbook.Sheets("Lending")

With AllSheet
  LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
  DestRow = LendSheet.Range("A" & LendSheet.Rows.Count).End(xlUp).Row + 1
  For RowCnt = 2 To LastRow
    If .Cells(RowCnt, 3).Value = "X" Or .Cells(RowCnt, 3).Value = "x" Then
        LendSheet.Rows(DestRow).Value = .Rows(RowCnt).Value
        DestRow = DestRow + 1
    End If
 Next
End With
'..... Remove Duplicates
Dim LastCol As String
With LendSheet
  LastCol = Split(.Range("A1").End(xlToRight).Address, "$")(1)
  .Range("A:" & LastCol).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), 
Header:=xlYes
End With

End Sub

Answer 1

“将数据复制到另一个工作表”可以分为一个单独的子项，它可以清理您的主代码，从而使添加新检查变得更加容易。

Private Sub CommandButton1_Click()

    Dim AllSheet As Worksheet
    Dim LastRow As Long
    Dim RowNum As Long

    Set AllSheet = ActiveWorkbook.Sheets("All")

    With AllSheet
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row

        For RowNum = 2 To LastRow

            If UCase(.Cells(RowNum, 3).Value) = "X" Then
                AppendRow .Rows(RowNum), "Lending"
            End If

            If UCase(.Cells(RowNum, 4).Value) = "BLAH" Then
                AppendRow .Rows(RowNum), "FX"
                AppendRow .Rows(RowNum), "Account" '<< can copy to >1 sheet...
            End If

        Next

    End With
    '..... Remove Duplicates
End Sub

'append a range to a named sheet
Sub AppendRow(rwSrc As Range, shtName As String)
    Dim rw As Range
    Set c = ActiveWorkbook.Sheets(shtName).Cells(Rows.Count, 1).End(xlUp) _
                                 .Offset(1, 0).Resize(1, rwSrc.Columns.Count)
    'make sure we're really copying to a blank row...
    Do While Application.CountA(rw) > 0
        Set rw = rw.Offset(1, 0)
    Loop
    rw.Value = rwSrc.Value
End Sub

使用命令按钮将数据复制到多个Excel工作表中

1 个答案: