Excel VBA宏可基于其他工作表中的值将粘贴值复制到其他工作表

Question

我目前正在研究费用监控Excel。 电子表格有很多工作表，其中包含大量数据。 但是为了简单起见，假设我只有三个工作表：

表格1-“输入”

表格2-“帐户XX”（简称XX）

表格3-“ YYYY帐户”（简称YY）

想法是费用数据将输入到“输入”表中的某个表中。 该表具有“ ACCOUNT”列，用于选择从中进行费用支出的帐户。 然后，通过单击宏按钮，费用数据将被转移到相应的其他工作表（XX或YY），具体取决于在“帐户”列中输入的数据。

例如：

费用1（$ 50）-来自帐户YY

费用2（$ 100）-来自帐户XX

费用3（$ 150）-来自帐户YY

单击宏按钮时，费用1和费用3将被复制粘贴到工作表“ YY”，而费用2被粘贴到工作表“ XX”。

我尝试制作一个宏按钮，该按钮可能会将在“输入”表中输入的数据转移到其他表中，具体取决于在“帐户”列中输入的数据。 我试图将每个费用的“帐户”输入与其他工作表的页眉单元格（例如F1）进行比较，其中包含特定帐户的文本/名称。

例如：

费用1（$ 50）-由帐户YY ≠表格XX的单元格F1值： “帐户XX”

费用1（$ 50）-由帐户YY =表格YY单元格F1值： “帐户YY”

因此，复制到工作表YY。

但是我不能使它工作。 当我单击按钮时，没有任何反应。 我不知道到底是哪里错了。 我尝试研究如何使excel VBA选择将值粘贴到的工作表，但仍无法按预期工作。 有什么想法或建议吗？ 谢谢。

请参阅下面的代码以供参考。

Sub EXPENSES()
Dim nextrow As Long
Dim rowcount As Long
Dim x As Long
For Each Worksheet In Worksheets
    rowcount = Worksheets("INPUT").Range("B19").Value
    For x = 1 To rowcount
        If Worksheet.Range("F1").Value = Worksheets("INPUT").Range("E" & 9 + x - 1).Value Then
        nextrow = Worksheet.Cells(Rows.Count, "G").End(xlUp).Row + 1
        If nextrow < 18 Then nextrow = 18
        Worksheet.Range("B" & nextrow + x - 1).Value = Worksheets("INPUT").Range("B" & 9 + x - 1).Value
        End If
    Next x
Next Worksheet
End Sub

请查看“输入”和“帐户XX”表的屏幕截图。 还包括样本数据供您参考。

输入表

帐户XX工作表

真诚的

弗里兹

Answer 1

我对您的代码进行了一些更改。 此代码应工作：

Sub EXPENSES()
Dim nextrow As Long
Dim rowcount As Long
Dim x As Long
Dim Worksheet As Object
For Each Worksheet In Worksheets
    rowcount = Worksheets("INPUT").Range("B19").Value
    For x = 1 To rowcount
        If Worksheet.Range("F1").Value = Worksheets("INPUT").Range("E" & 9 + x - 1).Value Then
            nextrow = Worksheet.Cells(Rows.Count, "B").End(xlUp).Row + 1
            If nextrow < 18 Then nextrow = 18
            Worksheet.Range("B" & nextrow).Value = Worksheets("INPUT").Range("B" & 9 + x - 1).Value
        End If
    Next x
Next Worksheet
End Sub

或替代方案，更快的解决方案：

Sub EXPENSES_Alt()
Dim nextrow As Long
Dim rowcount As Long
Dim x As Long
Dim Worksheet_Name As String
rowcount = Worksheets("INPUT").Range("B19").Value
For x = 1 To rowcount
    Worksheet_Name = Right(Worksheets("INPUT").Range("E" & 8 + x).Value, 2)
    nextrow = Worksheets(Worksheet_Name).Cells(Rows.Count, "B").End(xlUp).Row + 1
    If nextrow < 18 Then nextrow = 18
    Worksheets(Worksheet_Name).Range("B" & nextrow).Value = Worksheets("INPUT").Range("B" & 8 + x).Value
Next x
End Sub