Recorded Macro - Shorter (more efficient) way? Please look!

[mwalls33]

Hi all - so I'm trying to see if there's a shorter/better version of what I'm doing? I have a macro created that I look up a value from one workbook to another and copy everything that's from the 2nd workbook to the first workbook. But I want to know if there's a way to put this in loop till the last record and the look up value to be more efficient and cleaner? here's what the recorded macro looks like.

Windows("NonPersonnelExtract 07-23-18.xlsx").Activate
Range("D1").Select
Selection.AutoFilter
Windows("Transfer File.xlsx").Activate
Range("E2").Select
Selection.Copy
Windows("NonPersonnelExtract 07-23-18.xlsx").Activate
ActiveSheet.Range("$A$1:$J$107854").AutoFilter Field:=4, Criteria1:= _
"DAM1996"
ActiveWindow.SmallScroll Down:=-3
Range("B1:F22910").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Transfer File.xlsx").Activate
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
Cells.Select
Cells.EntireColumn.AutoFit
Range("B10").Select
Sheets("Non-personnel Transfers").Select
Range("E3").Select
Application.CutCopyMode = False
Selection.Copy
Windows("NonPersonnelExtract 07-23-18.xlsx").Activate
ActiveSheet.Range("$A$1:$J$107854").AutoFilter Field:=4, Criteria1:= _
"JOB8065"
ActiveWindow.SmallScroll Down:=-21
Range("B1:F105415").Select
Application.CutCopyMode = False
Selection.Copy
Range("B105415:F105415").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Transfer File.xlsx").Activate
Sheets("Sheet1").Select
Range("A4").Select
ActiveSheet.Paste
Sheets("Non-personnel Transfers").Select
Range("E4").Select
Application.CutCopyMode = False
Selection.Copy
Windows("NonPersonnelExtract 07-23-18.xlsx").Activate
ActiveSheet.Range("$A$1:$J$107854").AutoFilter Field:=4, Criteria1:= _
"JXZ2388"
ActiveWindow.SmallScroll Down:=-12
Range("B90712:F105206").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Transfer File.xlsx").Activate
Sheets("Sheet1").Select
Range("A5").Select
ActiveSheet.Paste
Sheets("Non-personnel Transfers").Select
Range("E5").Select
Application.CutCopyMode = False
Selection.Copy
Windows("NonPersonnelExtract 07-23-18.xlsx").Activate
ActiveSheet.Range("$A$1:$J$107854").AutoFilter Field:=4, Criteria1:= _
"KKS2759"
ActiveWindow.SmallScroll Down:=-12
Range("B107181:F107509").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Transfer File.xlsx").Activate
Sheets("Sheet1").Select
Range("A17").Select
ActiveSheet.Paste
Sheets("Non-personnel Transfers").Select
Range("E6").Select
Application.CutCopyMode = False
Selection.Copy
Windows("NonPersonnelExtract 07-23-18.xlsx").Activate
ActiveSheet.Range("$A$1:$J$107854").AutoFilter Field:=4, Criteria1:= _
"MXN8497"
ActiveWindow.SmallScroll Down:=-6
Range("B21893:F21893").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Transfer File.xlsx").Activate
Sheets("Sheet1").Select
Range("A20").Select
ActiveSheet.Paste
Sheets("Non-personnel Transfers").Select
Range("C11").Select

 

[mse330]

Hey mwalls33,

Based on my understanding of your recorded macro, insert the below code in a module in your "Transfer File" then run the macro & a box will appear to select the file that you need to copy the data from "NonPersonnelExtract 07-23-18.xlsx" (I haven't hardcoded this file in the VBA code because I assume this will change everyday or so).

Sub Copy()
Application.ScreenUpdating = False
Dim Wb1 As Workbook, Wb2 As Workbook, Ws1 As Worksheet, Ws2 As Worksheet, Rg As Range, FilePath As String
Dim Arr() As Variant, lRow1 As Long, lRow2 As Long
Set Wb1 = ActiveWorkbook
FilePath = Application.GetOpenFilename()
Set Wb2 = Workbooks.Open(FilePath)
Set Rg = Wb2.ActiveSheet.Range("A1").CurrentRegion
Arr = Rg
Wb2.Close False
Wb1.Activate
Set Ws1 = Sheets("Non-personnel Transfers")
Set Ws2 = Sheets.Add(After:=ActiveSheet)
lRow1 = Ws1.Range("E" & Rows.Count).End(xlUp).Row
Ws2.Range("A1").Resize(, UBound(Arr, 2)).Value = Application.Index(Arr, 0)
For x = 2 To lRow1
    For i = LBound(Arr) To UBound(Arr)
        If Arr(i, 4) = Ws1.Cells(x, 5) Then
            lRow2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
            For y = 1 To UBound(Arr, 2)
                Ws2.Cells(lRow2, y) = Arr(i, y)
            Next y
'            Ws2.Range("A" & lRow2).Resize(, UBound(Arr, 2)).Value = Application.Index(Arr, i)
        End If
    Next i
Next x
Application.ScreenUpdating = True
End Sub

 

[mwalls33]

omg this works perfectly!!!!! thank you soooo much!! I can't thank you enough!

 

[mse330]

Glad to help & thanks for reporting back