VBA根據某些用戶輸入的標准將數據從一個工作簿復制並粘貼到另一個工作簿？

Question

所以我有工作簿 1，其中包含我們帳戶中每個人的當月交易詳細信息（E 列的帳號列為“-xxxxx”）。 在工作簿 2 中，我為工作簿 1 中的每個唯一帳號都有一張工作表（B3 的每個工作表中的帳號，格式為“xxxxx”，沒有“-”，就像工作簿 1 中一樣）。 我需要按帳號過濾工作簿 1 中的所有交易（最好是通過工作簿 2 中的用戶選擇范圍，以便我可以單擊單元格 B3 或它自動選擇活動工作表的 B3 並且它知道按該值過濾）然后有復制並粘貼到工作簿 2 的相應工作表中的那些過濾行的 A、C 和 F 列的數據（可能再次是活動工作表，因為我將從工作簿 2 中的每個工作表運行宏）。

例如

1. 運行宏
2. 提示選擇要從中復制的工作簿（工作簿 1 - 文件每月更改，因此可以選擇源工作簿）
3. 提示選擇哪個帳號。 這可以手動或從單元格 B3 中自動選擇（例如值為“12345”），用於工作簿 2 中的工作表
4. Excel 然后自動篩選並復制工作簿 1 中具有“12345”的數據/行（但對於篩選的行/事務，只有列“A”（日期）、“C”（描述）和“F”（金額） ) 並將其粘貼回工作簿 2 中的活動工作表（從每個工作表中的單元格 A7 開始），我從中獲得了帳號
5. 工作簿 1 中的數據分別從 A、C 和 F 列到 A、B 和 C
6. 為從 F 列（現在在 C 列）復制的數據運行我編寫的宏（可能效果不佳 - 但它有效），它消除了所有負數。
7. 然后我可以移動到下一張表並為以下帳戶重新運行宏。

我對編碼/vba 非常陌生，請原諒我的無知。 盡我所能去學習。

復制代碼：

Sub Copy_data()

    Application.ScreenUpdating = False

    Dim UserRange As Range
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim UserAcc As Range
    Dim LastRow As Long
    
    Set wb1 = Workbooks("Fresh AMEX May 24- June 22.xlsx") 'source book, can't figure out how to make this user input. inputbox?'
    Set wb2 = ThisWorkbook
    Set ws1 = Workbooks("Fresh AMEX May 24- June 22.xlsx").Sheets("Transaction Details") 'assuming the worksheet can just be selected and the first workbook selection can be omitted'
    Set ws2 = ThisWorkbook.Sheets("Test1")
    
    'user input to select account number for criteria'
    On Error Resume Next
        Set UserAcc = Application.InputBox(Prompt:="Select an ACCOUNT NUMBER", Title:="Select an ACCOUNT NUMBER", Default:=ActiveCell.Address, Type:=8)
        If UserAcc Is Nothing Then Exit Sub
        On Error GoTo 0
    

    With ws1
        LastRow = Cells(Rows.Count, "E").End(xlUp).Row
        ws1.Range("A1:0" & LastRow).AutoFilter Field:=5, Criteria1:="UserAcc"
        Intersect(.Offset(1), .Parent.Range("A:A,C:C,F:F")).Copy 'found this online that is supposed to only copy the desired columns, but can't get ti to work'
        
        With ws2.Range("A" & LastRow(ws2) + 1) 'also get a compile error here at LastRow if I omit the abover Intersect function. I get "expected array" as the error.
            .PasteSpecial xlPasteValues
        End With
    End With
End Sub

負數去除碼：

Sub Deleter()
    Dim xRg As Range
    Dim xCell As Range
    Dim xTxt As String
    Dim i As Long
    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
Sel:
    Set xRg = Nothing
    Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    If xRg.Areas.Count > 1 Then
        MsgBox "does not support multiple selections, please select again", vbInformation, "Kutools for Excel"
        GoTo Sel
    End If
    If xRg.Columns.Count > 1 Then
        MsgBox "does not support multiple columns, please select again", vbInformation, "Kutools for Excel"
        GoTo Sel
    End If
    For i = xRg.Rows.Count To 1 Step -1
        If xRg.Cells(i) < 0 Then xRg.Cells(i).EntireRow.Delete
    Next
End Sub

非常感謝大家的幫助！

Answer 1

你大部分時間都在那里。 要讓最終用戶選擇文件，您可以使用Application.GetOpenFileName方法。 我還糾正了其他一些事情，並對代碼進行了大量注釋，以使其更清楚它在做什么：

Sub Copy_data()
    
    'Have end user select file using the Application.GetOpenFilename method
    Dim sSrcFilePath As String
    sSrcFilePath = Application.GetOpenFilename("Excel Files, *.xls*", , "Select Excel File", , False)
    If sSrcFilePath = "False" Then Exit Sub 'Pressed cancel
    
    'Delcare variables
    Dim wbSrc As Workbook:  Set wbSrc = Workbooks.Open(sSrcFilePath)    'Open selected workbook
    Dim wsSrc As Worksheet: Set wsSrc = wbSrc.Worksheets("Transaction Details")
    Dim wbDst As Workbook:  Set wbDst = ThisWorkbook
    Dim wsDst As Worksheet: Set wsDst = wbDst.ActiveSheet
    Dim rAcctNum As Range:  Set rAcctNum = wsDst.Range("B3")
    Dim rDst As Range:      Set rDst = wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Offset(1)
    If rDst.Row < 7 Then Set rDst = wsDst.Range("A7")   'Guarantee that paste starts at row 7, otherwise append to existing data
    
    'Verify the account number is a valid number
    If Not IsNumeric(rAcctNum.Value) Then
        wbSrc.Close False   'Close the source workbook due to error
        rAcctNum.Select
        MsgBox "ERROR: Account number must be numeric!"
        Exit Sub
    End If
    
    'Filter on column E of source worksheet
    With wsSrc.Range("E1", wsSrc.Cells(wsSrc.Rows.Count, "E").End(xlUp))
        .AutoFilter 1, -rAcctNum.Value  'Notice the - in front of the rAcctNum in order to filter properly
                                        'This is because in your description, the source workbook has "-xxxxx" for the acct nums
        
        'Copy filtered values from columns A, C, and F
        'You were close here, need to make sure you specify .EntireRow so that you don't end up with an error on the Intersect
        Intersect(.Offset(1).EntireRow, .Parent.Range("A:A,C:C,F:F")).Copy
        rDst.PasteSpecial xlPasteValues 'Paste to destination as values
        
        .AutoFilter 'Remove filter
        .Parent.Parent.Close False 'Close source workbook, False means Don't save changes
    End With
    
    'Prep selected cells for your Deleter Sub
    Intersect(Selection, wsDst.Columns("C")).Select
    Call Deleter
    
End Sub