VBA copy and paste data based on certain user inputed criteria from one workbook to another?-CodePudding

So I have workbook 1 that has transaction details for the month for everyone on our account (column E has the account numbers listed as "-xxxxx"). In workbook 2 I have a sheet for each unique account number that is in workbook 1 (account number in each sheet at B3 in the format of "xxxxx" with no "-" like in workbook 1). I need to filter all transactions in workbook 1 by account number (ideally by a user-selected range in Workbook 2 so I can click cell B3 or it auto-selects the active sheet's B3 and it knows to filter by that value) and then have the data of columns A, C, and F for those filtered rows copied and pasted in the respective sheet in workbook 2 (could again be active sheet since I'll be running the macro from each sheet in workbook 2).

E.G.

Run the macro
Prompted to select which workbook to copy from (workbook 1--the file changes each month hence the option to select the source workbook)
Prompted to select which account number. This can be manually or auto-selected from cell B3 (e.g. value is "12345") for sheets in workbook 2
Excel then auto-filters and copies the data/rows that have "12345" from workbook 1 (but only columns "A" (date), "C" (description), and "F" (amount) for the filtered rows/transactions) and pastes it back to the active sheet in workbook 2 (starting at cell A7 in each sheet) where I got the account number from
Data from workbook 1 goes from column A, C, and F to A, B, and C respectively
Run a macro I wrote (probably poorly--but it works) for the data copied from column F (now in column C) that gets rid of all negative numbers.
Then I can move to the next sheet and rerun the macro for the following accounts.

I'm incredibly new to coding/vba, excuse my ignorance. Trying my best to learn.

Copying Code:

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

Negative number removal code:

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

Thank you all so much for the help!

CodePudding user response：

You were mostly there. To have the end user select a file, you can use the Application.GetOpenFileName method. I've also corrected some other things and heavily commented the code to make it clearer what it's doing:

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