Get data from another workbook and paste to master template based on criteria

wilsonwilson4

New member
Joined
Apr 21, 2017
Messages
2
Reaction score
0
Points
0
Hi XLGuru,

I am wondering anyone can help me to modify little bit with the vba below. I want to create a vba that can do flexible pick up from different work by using application.getopenfilename rather than i have to put the directory in another worksheet to pull up the data.

Could anyone advise?


Application.GetOpenFilename("Excel-files,*.xls", _
1,"Select One File To Open",,False)

Code:
[COLOR=#303336][FONT=Consolas]Public Sub GetData()[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]Dim Source As String[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]Source = Dir(Sheet1.Range("J1").Value) '[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]If Source = "" Then[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]MsgBox "Source file doest not exist/moved!", vbExclamation, "Source File Status"[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]Exit Sub[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]End If[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]Application.ScreenUpdating = False[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]Dim mydata As String[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]Dim strFileName As String[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]Dim strFile As String[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]strFileName = Sheet1.Range("J1").Value[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]strFile = Dir(strFileName)[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]strFileName = Replace(strFileName, strFile, "")[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]mydata = "=" & "'" & strFileName & "[" & strFile & "]" & "RawData" & "'" & "!A1:AT10000"[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]With Sheet2.Range("A1:AT10000")[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas].Formula = mydata[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas].Value = .Value[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]End With[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]Sheet2.Columns("A:AT").AutoFit[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]ThisWorkbook.Worksheets("Result").Range("A1:AT10000").Replace What:="0", Replacement:="", LookAt:=xlWhole[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]Columns(1).EntireColumn.Delete[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]Application.ScreenUpdating = True[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]MsgBox "Done", vbInformation, "Done"[/FONT][/COLOR]
[COLOR=#303336][FONT=Consolas]End Sub[/FONT][/COLOR]
 

Attachments

  • RAW DATA.xlsx
    14.1 KB · Views: 19
  • Template.xlsm
    16.4 KB · Views: 13
Back
Top