Excel VBA Copy a Workbook to another one with Dialog - vba

I am a beginner in Excel VBA programming and am tasked to develop a Tool in Excel for monitoring. I do have knowledge in other Languages like Java, C++ and Python, therefore I know how to do the Logic, but VBA is a difficult one.
The Thing:
What I need to get working is the following:
I have a Workbook, lets call it Tool.xlsm in which I've wrote the sorting and filtering logic. This part is working fine. It uses a seperate sheet in that workbook for the "background data". This sheet is what this is about.
I want to write a macro which displays a file selection dialouge. The selected file then gets copied to a new sheet in my Workbook. The file is a .xls table with 3 sheets. The data needed is in sheet 1.
Public Sub copyData()
Set appxl = CreateObject("Excel.application")
Dim myfile As Window
Dim currentSheet As Worksheet
Dim lastRow As Double
Dim sourceFileName As String
sourceFileName = "FileToCopy.xlsx"
'Open Source File.xlsx
With appxl
.Workbooks.Open ActiveWorkbook.Path & "\" & sourceFileName
.Visible = False
End With
'Get first sheet data
Set myfile = appxl.Windows(sourceFileName)
myfile.Activate
Set currentSheet = appxl.Sheets(1)
'Past the table in my current Excel file
lastRow = currentSheet.Range("A1").End(xlDown).Row
Sheets("Data retrieval").Range("A1:Y" & lastRow) = currentSheet.Range("A1:Y"& lastRow).Value
'Close Source File.xlsx
appxl.Workbooks(sourceFileName).Close
End Sub
This is the Code I wrote with the help of the famous GoogleSearch.
Now to the Specific Questions:
How do I code a FileSelectionDialouge?
how do I fix the error 9, outofBounds?
Ive searched in Stackoverflow for quite some time, but didnt find a similar problem.
This is my first Post here, I apologize for any mistakes made.
Also I apologize for any grammar or vocabular mistakes, english is not my native language :)
Many thanks for reading.
Ninsa
Edit: Ive modified the code according to the answers below. It now looks like this:
Public Sub copyData2()
Set appxl = CreateObject("Excel.application")
Dim myfile As Window
Dim currentSheet As Worksheet
Dim lastRow As Double
Dim sourceFileName As String
'Ask the user to select a file
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.ButtonName = "Import File"
.InitialView = msoFileDialogViewSmallIcons
.Title = "Please Select File"
If .Show = -1 Then Collation_File = .SelectedItems(1)
End With
sourceFileName = Collation_File
'Open Source File.xlsx
With appxl
.Workbooks.Open Collation_File
.Visible = False
End With
'Get first sheet data
Set myfile = appxl.Windows(sourceFileName)
myfile.Activate
Set currentSheet = Workbooks("sourceFileName").Sheets(1)
'Past the table in my current Excel file
lastRow = currentSheet.Range("A1").End(xlDown).Row
Debug.Print lastRow
Sheets("test").Range("A1:Y" & lastRow) = currentSheet.Range("A1:Y" & lastRow).Value
'Close Source File.xlsx
appxl.Workbooks(sourceFileName).Close
End Sub

For the first part you could use the following function based on this article in MSDN
Function GetFileName() As String
GetFileName = ""
' Open the file dialog
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
If .Show = -1 Then
GetFileName = .SelectedItems(1)
End If
End With
End Function
Update I re-wrote your code to
Public Sub copyData()
Dim sourceWkb As Workbook
Dim sourceWks As Worksheet
Dim targetWks As Worksheet
Dim sourceFilename As String
Dim lastRow As Long
Set targetWks = Sheets("Data retrieval")
sourceFilename = GetFileName
Set sourceWkb = Workbooks.Open(sourceFilename)
Set sourceWks = sourceWkb.Sheets(1)
'Past the table in my current Excel file
lastRow = sourceWks.Range("A1").End(xlDown).Row
targetWks.Range("A1:Y" & lastRow) = sourceWks.Range("A1:Y" & lastRow).Value
'Close Source File.xlsx
sourceWkb.Close False
End Sub
With Application.ScreenUpdating = Falseyou can turn off screen flickering.

Related

VBA: Run-Time Automation Error - "Code execution has been interrupted"

I'm attempting to write a program to loop through a directory of excel files and copy a range into a "Master Workbook". When I run the program I am prompted with "Code execution has been interrupted". If I select continue the code will successfully run but then a "run-time error '-2147221080' Automation error" appears.
The line that causes the error is:
Set ws = wb.Worksheets("Project Log")
My question is, why is this line causing the error and or is there a way to bypass the error prompt so that my code will successfully run?
Sub FileCompiler()
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim Masterwb As Workbook
Dim ws as Worksheet
'set workbook in which data will be copied to
Set Masterwb = ActiveWorkbook
'declare path
'folderPath = "C:MyPath\"
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
'compile directory data to master spreadsheet
Filename = Dir(folderPath & "*.xls*")
Do While Filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & Filename)
Set ws = wb.Worksheets("Project Log")
ws.Range(ws.Cells(2, "C"), ws.Cells(2, "C")).Copy
Masterwb.Worksheets("Staging").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
ws.Range(ws.Cells(7, "A"), ws.Cells(Rows.Count, "K").End(xlUp)).Copy
Masterwb.Worksheets("Staging").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
wb.Close True
Filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
Dim Finfo As String
Dim FilterIndex As Long
Dim Title As String
Dim CopyBook As Workbook
Dim CopySheet As Worksheet
Dim ForecastFileName As Variant
Dim MasterSheet AS Worksheet
Set MasterSheet = ThisWorkbook.Worksheets("Yoursheetname")
'now you can always use master sheet after you set copybook
'Set up file filter
Finfo = "Excel Files (*.xls*),*.xls*"
'Set filter index to Excel Files by default in case more are added
FilterIndex = 1
' set Caption for dialogue box
Title = "Hey there!, select a file"
'get the Forecast Filename
ForecastFileName = Application.GetOpenFilename(Finfo, FilterIndex, Title)
'Change this according to what you need for workbook and worksheet names
Workbooks.Open (ForecastFileName)
Set CopyBook = ActiveWorkbook
Set CopySheet = CopyBook.Worksheets(1)
'Do your code, remember to close
CopyBook.Close savechanges:=False 'Not needed now
You might want to check for the ForecastFileName being False, that is when the users x's out, you will also want to do a little validation the wb sheet is in the right format by checking column headers ect or you will wind up crashing.

Exporting Selection to CSV

I've created a excel spreadsheet template for our customers to populate and send back to us. I want to manually select their populated data and save it as a .csv to import into another piece of software. I, first, attempted this by recording a macro. This didn't work because different customers send different numbers of records.
I've tried snippets of code from online research and came up with this.
Sub Select_To_CSV()
Dim rng As Range
Dim myrangearea()
Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight)).Select
Dim myPath As String, v
myPath = "p:\" & _
Format(Date, "yyyymmdd") & ".csv"
'myPath = "x:\" & Format(Date, "yyyymmdd") & ".csv"
v = SaveAs(myPath)
If v <> False Then ThisWorkbook.SaveAs v
End Sub
Function SaveAs(initialFilename As String)
On Error GoTo EndNow
SaveAs = False
With Application.FileDialog(msoFileDialogSaveAs)
.AllowMultiSelect = False
.ButtonName = "&Save As"
.initialFilename = initialFilename
.Title = "File Save As"
'.Execute
.Show
SaveAs = .SelectedItems(1)
End With
EndNow:
End Function
Sub Select_To_CSV()
Dim rng As Range
Dim myrangearea()
Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight)).Select
Dim myPath As String, v
myPath = "p:\" & _
Format(Date, "yyyymmdd") & ".csv"
'myPath = "x:\" & Format(Date, "yyyymmdd") & ".csv"
v = SaveAs(myPath)
If v <> False Then ThisWorkbook.SaveAs v
End Sub
This worked really well except when I went back to look at the .csv in the folder it was the same worksheet not the selected columns.
Ultimately what I am looking to do is,
Manually select the columns I want
Run a macro that converts the selected columns to a .csv
Have the Save As Dialog Box appear
Navigate to the certain folder I want.
Here you go:
Sub MacroMan()
ChDrive "P:" '// <~~ change current drive to P:\
Dim copyRng As Excel.Range
Dim ThisWB As Excel.Workbook
Dim OtherWB As Excel.Workbook
Dim sName As String
'// set reference to the 'Master' workbook
Set ThisWB = ActiveWorkbook
'// assign selected range to 'copyRng'
Set copyRng = Application.InputBox(Prompt:="Select range to convert to CSV", Type:=8)
'// If the user selected a range, then proceed with rest of code:
If Not copyRng Is Nothing Then
'// Create a new workbook with 1 sheet.
Set OtherWB = Workbooks.Add(1)
'// Get A1, then expand this 'selection' to the same size as copyRng.
'// Then assign the value of copyRng to this area (similar to copy/paste)
OtherWB.Sheets(1).Range("A1").Resize(copyRng.Rows.Count, copyRng.Columns.Count).Value = copyRng.Value
'// Get save name for CSV file.
sName = Application.GetSaveAsFilename(FileFilter:="CSV files (*.csv), *.csv")
'// If the user entered a save name then proceed:
If Not LCase(sName) = "false" Then
'// Turn off alerts
Application.DisplayAlerts = False
'// Save the 'copy' workbook as a CSV file
OtherWB.SaveAs sName, xlCSV
'// Close the 'copy' workbook
OtherWB.Close
'// Turn alerts back on
Application.DisplayAlerts = True
End If
'// Make the 'Master' workbook the active workbook again
ThisWB.Activate
MsgBox "Conversion complete", vbInformation
End If
End Sub
This will allow you to manually select a range (including entire columns). It will then transfer said range onto a new sheet, save that sheet as a CSV, using the Save As dialog, and then close it afterwards.

Excel VB for importing data from folders

I am working on a project in excel that requires importing data from files on network.
The issue I am facing is as follows:
I have a folder (in shared drive) in which there are few sub-folders and an excel file in the end sub-folder. The excel file has many tabs out of which I have to import the data from only 1 particular tab (e.g. Summary). This process has to be repeated for all the files in all the sub-folders.
Here is the flow diagram of the description.
Folder A -> Sub-folder1 -> Sub-folder2 -> {Excel file1, Excel file2}
Now, what I am looking for is, that whenever I add a new excel file in the sub-folder 2, the data from that same tab (Summary) of the excel file (all excel files have same tabs with different data) should be imported to my destination excel file and make a graph of the data. I need a VB script to run this functionality.
Also, if I have more sub-folders, then will VB take longer time to run ?
I tried the following but doesn't seem to work:
Sub ConFiles()
Dim Wbname As String
Dim Wb As Workbook
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim lngCalc As Long
Dim lngrow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .CalculationState
.Calculation = xlCalculationManual
End With
Set ws1 = ThisWorkbook.Sheets.Add
'change folder path here
FolderName = "C:\temp"
Wbname = Dir(FolderName & "\" & "*.xls*")
'ThisWorkbook.Sheets(1).UsedRange.ClearContents
Do While Len(Wbname) > 0
Set Wb = Workbooks.Open(FolderName & "\" & Wbname)
Set ws = Nothing
On Error Resume Next
'change sheet name here
Set ws = Wb.Sheets("loging form")
On Error GoTo 0
If Not ws Is Nothing Then
lngrow = lngrow + 1
ws.Rows(2).Copy ws1.Cells(lngrow, "A")
End If
Wb.Close False
Wbname = Dir
Loop
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
End With
End Sub
Function GetExcelFiles(ByVal strFilePath As String) As String()
Dim arrStr As String() = Nothing
If Directory.Exists(strFilePath) Then
arrStr = GetFilePath(strFilePath)
Else
'error message here
End If
Return arrStr
End Function
Private Function GetFilePath(ByVal strFilePath As String) As String()
Dim arrFileNames As String() = Directory.GetFiles(strFilePath, "*.xls", SearchOption.AllDirectories)
Return arrFileNames
End Function
The code above is how to get all excel files. Next thing is... open the workbook and read per worksheet. To read file by file, you can loop using For Each.
For Each strFileName In arrStr
'your code here
Next
where strFileName = GetExcelFiles(folderPath)
Don't forget to add Imports Microsoft.Office.Interop.Excel
then
Dim excel As New Application
Dim workbook As Workbook = excel.Workbooks.Open(strFileName)
Now you have the workbook. To read per sheet, do it this way and put it in a function that returns boolean.
Dim worksheet As Worksheet
For intIndex As Integer = 1 To workbook.Sheets.Count
worksheet = workbook.Sheets(intIndex)
If worksheet.Name.Equals(THE_SHEETNAME) Then
'returns true
Exit For
End If
Next
Now you can proceed with your process.

copy information to an external workbook

I am writing a macro where I take data from a CSV and copy it to another Excel file (not the current or active file).
What is the code to take the copied data and send it to another file in the same directory.
This is my code, I have commented out the lines that cause the macro not to work. I want to set the variable wshT to Sheet1 of the WTF.xlsx file, which is in the same directory but not the active workbook. I have not opened that one. So the goal is to use this macro to copy extra data from the CSV and send it to the WTF.xlsx file and save it as something new, in this case "BBB". Any help is much appreciated. When I uncomment those lines, errors pop up.
Sub Import()
Dim MyPath As String
Dim strFileName As String
'Dim strFileName1 As String
MyPath = ActiveWorkbook.Path
strFileName = MyPath & "\borgwich_die_BM1940_profile.csv"
'strFileName1 = Workbooks("WTF.xlsx").Activate
'strFileName1 = Workbooks("WTF.xlsx").Worksheets("Sheet1").Select
Dim wbkS As Workbook
Dim wshS As Worksheet
Dim wshT As Worksheet
'Set wshT = strFileName1
Set wbkS = Workbooks.Open(Filename:=strFileName)
Set wshS = wbkS.Worksheets(1)
wshS.Range("A1:A3").EntireRow.Delete
'wshS.UsedRange.Copy Destination:=wshT.Range("A1")
wbkS.Close SaveChanges:=False
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=MyPath & "\BBB", FileFormat _
:=51, CreateBackup:=False
Application.DisplayAlerts = False
'ActiveWindow.Close
End Sub
Your use of value assignment to strFileName1 through the use of .Activate and/or .Select was bad methodology. If WTF.xlsx is open, you can directly reference its Sheet1 and Set a worksheet object reference to a variable.
Sub Import()
Dim MyPath As String, strFileName As String
Dim wbkS As Workbook, wshS As Worksheet, wshT As Worksheet
MyPath = ActiveWorkbook.Path
strFileName = MyPath & "\borgwich_die_BM1940_profile.csv"
Set wbkS = Workbooks.Open(Filename:=strFileName)
Set wshS = wbkS.Worksheets(1)
Set wshT = Workbooks("WTF.xlsx").Worksheets("Sheet1")
wshS.Range("A1:A3").EntireRow.Delete
With wshS.Cells(1, 1).CurrentRegion
.Copy Destination:=wshT.Range("A1")
End With
wbkS.Close SaveChanges:=False
Application.DisplayAlerts = False
wshT.Parent.SaveAs Filename:=MyPath & "\BBB", FileFormat:=51, CreateBackup:=False
wshT.Parent.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
Another alternative would be to use the VBA equivalent of Data ► Get External Data ► From Text but you should probably know the number and type of fields being brought in with the CSV beforehand. This is certainly the preferred method if the CSV data is being incorrectly interpreted by the temp worksheet you are creating by opening the CSV as a workbook.

Copy Range from multiple workbooks in folder to Summary Workbook also in folder?

I have a folder with 100+ workbooks. These workbooks contain a range of data. For simplicity I will call the data range A1:D2, the range is located on Sheet1 of all 100+ workbooks.
I also have a Summary workbook.
I would like to place VBA code in the Summary workbook that loops through the folder, copying the range A1:D2 of each of the 100+ workbooks.
I would then like to paste the A1:D2 range from each workbook in to Sheet1 of the Summary workbook. Each paste will start on the next unused row.
I am stuck doing this via a manual process right now and it is driving me insane.
I do know some basic VBA coding however my problem is that I can't figure out how to loop it correctly, and I am stuck coding each individual workbook to open-->copy-->paste-->close. This was fine with 10-20 workbooks but now I am at 100+ and it is growing every week.
Thanks again,
Brian
I have something that does exactly what you are asking for, if you want to copy multiple workbooks I suggest creating a new worksheet to capture the workbook information onto a spreadsheet. Instructions below
Create a new worksheet and give it a name, in this case we'll call the sheet 'Control'
Create a new module in VBA and use the code below to operate the workbook copy
I have left a section out for you to write your code for the functions that you want to perform.
Sub WorkbookConsolidator()
Dim WB As Workbook, wb1 as workbook
Dim WBName as Range
Dim folderselect as Variant, wbA as Variant, wbB as Variant,
Dim I as long, J as long
Dim objFolder As Object, objFile As Object
Dim WBRange as String
'Set Core Variables and Open Folder containing workbooks.
Set WB = ThisWorkbook
Worksheets("Control").Activate
Set FolderSelect = Application.FileDialog(msoFileDialogFolderPicker)
FolderSelect.AllowMultiSelect = False
MsgBox ("Please Select the Folder containing your Workbooks")
FolderSelect.Show
WBRange = FolderSelect.SelectedItems(1)
Set objFolder = objFSO.GetFolder(FolderSelect.SelectedItems(1))
' Fill out File name Fields in Control Sheet
' The workbook names will be captured in Column B
' This allows allocation for up to 100 workbooks
For I = 1 To 100
For Each objFile In objFolder.files
If objFile = "" Then Exit For
Cells(I, 2) = objFile.Name ' Workbook Name
Cells(I, 3) = WBRange ' Workbook Path
I = I + 1
Next objFile
Next I
'Loop through the list of workbooks created in the 'Control' Directory, adjust the loop range as preferred
For J = 100 To 1 Step -1
With Workbooks(ThisWorkbook).Worksheets("Control")
BookLocation = .Range("C" & J).Value
BookName = .Range("B" & J).Value
End With
Set wb1 = Workbooks.Open(Booklocation & Bookname)
' Write your code here'
CleanUp:
wb1.Close SaveChanges:=False
Next J
End Sub()
`
Try this
Sub combine_into_one()
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim strPath$, Pivot$, sUserName$, sFolderName$, sSourceName$, x&
Dim oFldialog As FileDialog
Dim oFile As Scripting.File
Dim oFolder
Set oFldialog = Application.FileDialog(msoFileDialogFolderPicker)
With oFldialog
If .Show = -1 Then
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
sFolderName = .SelectedItems(1)
End If
End With
Set oFolder = FSO.GetFolder(sFolderName)
Workbooks.Add: Pivot = ActiveWorkbook.Name 'Destination workbook
For Each oFile In oFolder.Files
Workbooks(Pivot).Activate
x = Workbooks(Pivot).Sheets("Sheet1").Cells.SpecialCells(xlCellTypeLastCell).Row + 1
Workbooks.Open filename:=oFile: sSourceName = ActiveWorkbook.Name
Workbooks(sSourceName).Activate
Workbooks(sSourceName).Sheets("Sheet1").[A1:D1].Copy
Workbooks(Pivot).Activate
Workbooks(Pivot).Sheets("Sheet1").Cells(x, 1).PasteSpecial xlPasteAll
Workbooks(sSourceName).Close False
Next
End Sub