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

Question

I'm currently working on an expense monitoring excel. The spreadsheet has many sheets with lots of data. But for simplicity, let's say I have only three worksheets:

Sheet 1 - "INPUT"

Sheet 2 - "ACCOUNT XX" (XX for short)

Sheet 3 - "ACCOUNT YY" (YY for short)

The idea is that expenses data will be inputted in a certain table in the "INPUT" sheet. The table has an "ACCOUNT" column to select which account the expense was made from. The expense data would then, with a click on a macro button, be transferred to the respective other sheets (XX or YY) depending on the data inputted in the "ACCOUNT" column.

For example:

Expense 1 ($50) - made from Account YY

Expense 2 ($100) - made from Account XX

Expense 3 ($150) - made from Account YY

When the macro button is clicked, Expense 1 and Expense 3 would be copy pasted to Sheet "YY" while Expense 2 to Sheet "XX".

I tried making a macro button which supposedly would transfer the data inputted in the "INPUT" sheet to the other sheets, depending on the data inputted in the "ACCOUNT" column. I tried to compare the "account" inputs for each expenses, with the header cell (say F1) of the other sheets, which contains the text/name of the particular account.

For Example:

Expense 1 ($50) - made from Account YY ≠ Sheet XX Cell F1 Value: "Account XX"

Expense 1 ($50) - made from Account YY = Sheet YY Cell F1 Value: "Account YY"

Therefore, copy to Sheet YY.

But I can't make it work. Nothing is happening when I click the button. I don't know what exactly is wrong. I tried researching on how to make excel VBA pick which sheet it will paste the value to, but still can't get it to work as it's supposed to. Any ideas or suggestions? Thank you.

Please see code below for your reference.

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

Please see screenshots of the "INPUT" and "ACCOUNT XX" sheets. Sample data are also included for your reference.

Input Sheet

Account XX Sheet

Sincerely,

Fritze

Answer 1

I have made some changes to your code. This code should work:

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

or alternative, shoret, faster solution:

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