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

【问题标题】：Copying data with command button into multiple excel sheets使用命令按钮将数据复制到多个 Excel 工作表中
【发布时间】：2018-09-12 15:57:35
【问题描述】：

我正在尝试制作一个命令按钮，根据它们是否满足要求，将数据从主工作表“全部”复制到 4 个不同的工作表中。我已经使用下面的代码使它与我的“贷款”一起使用，但是在接下来的 3 列中，我有数据“FX”“帐户”和“付款”，我希望这个命令按钮可以与所有床单。一些 dato 点将进入多张纸，而有些只能达到其中的一张。任何知道我如何扩展代码以使其工作的人？

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

【问题讨论】：

欢迎来到 Stackoverflow！如果您发布您尝试过的内容以及遇到的错误，您将获得更好的帮助。
Lendsheet 有一个循环，之后为其他工作表添加新循环
您不需要新的循环 - 只需在现有循环中添加额外的测试。

标签： excel vba

【解决方案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

【讨论】：