Exporting Selection to CSV - vba

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.

Related

Excel VBA Copy a Workbook to another one with Dialog

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.

Excel VBA XLDialogSaveAs function not working

I am trying to automatically save a .xls file in a hardcoded location, in the .xlsx file format. I want the SaveAs dialog to be showing the hardcoded location, and the file name that has been coded in the "File Name:" field . This is so that all I need to do is click on the Save button.
However, the SaveAs dialog always end up showing C Drive, when I want to save my file in the H Drive.
The following are my codes:
Option Explicit
Sub externalRatingChangeFile()
'Declare the data type of the variables
Dim wks As Worksheet
Dim sFilename As String
'Set wks to the current active worksheet
Set wks = ActiveWorkbook.ActiveSheet
'Set the location to save the file to a variable
sFilename = "H:\testing file"
'Save as .xlsx file in the specific location stated earlier
'If there are errors in the code, set wks to nothing and end the process
On Error GoTo err_handler
ChDrive sFilename
ChDir sFilename
Application.Dialogs(xlDialogSaveAs).Show (sFilename & "\TestingFile - " & Format(Date, "YYYYMMDD") & ".xlsx")
'System to/not display alerts to notify Users that they are replacing an existing file.
Application.DisplayAlerts = True
err_handler:
'Set Wks to its default value
Set wks = Nothing
End Sub
Instead of showing the Save As Dialog box, just save directly to the folder.
Application.DisplayAlerts = False
wks.SaveAs (sFilename + "\TestingFile - " + Format(Date, "YYYYMMDD") + ".xlsx")
Application.DisplayAlerts = True
or
Application.DisplayAlerts = False
wks.SaveCopyAs (sFilename + "\TestingFile - " + Format(Date, "YYYYMMDD") + ".xlsx")
Application.DisplayAlerts = True
Lastly you could create your own Dialog Box to make sure you are saving in the correct location:
'Result = 2 is Cancel
'Result = 1 is Ok
result = MsgBox("Would You Like To Save in the Following Location: " + "H:\Test File....", vbOKCancel, "Save As")
While I prefer the Application.GetSaveAsFilename method (see this), setting the initial folder on a xlDialogSaveAs should be no problem providing that the original workbook has not been previously saved.
Sub externalRatingChangeFile()
Dim bSaved As Boolean
Dim xlsxFileFormat As XlFileFormat
'Declare the data type of the variables
Dim wks As Worksheet
Dim sFilename As String
'Set wks to the current active worksheet
Set wks = ActiveWorkbook.ActiveSheet
'Set the location to save the file to a variable
sFilename = "H:\testing file"
xlsxFileFormat = XlFileFormat.xlOpenXMLWorkbook
'Save as .xlsx file in the specific location stated earlier
On Error GoTo err_handler
bSaved = Application.Dialogs(xlDialogSaveAs).Show(Arg1:=sFilename & "\TestingFile - " & Format(Date, "YYYYMMDD"), _
arg2:=xlsxFileFormat)
'System to/not display alerts to notify Users that they are replacing an existing file.
Application.DisplayAlerts = True
err_handler:
'Set Wks to its default value
Set wks = Nothing
End Sub

How do I merge multiple selected excel files in VBA?

I'm new with VBA and I'm wondering on how to merge multiple selected excel files using VBA. I tried coding the part of selecting files. I've researched and tried copying the codes on the internet and did some editing. I learned that you can add filters so I did that. But sometimes, the excel files won't show even if I added the correct filter (based on what I've researched). I really need to merge multiple selected excel files. I hope you can help me.
I'm using a userform, btw. One button that would allow to select and merge the selected files. And if possible, I want the user to see the path of the selected files. I don't know yet on how to do that, or what tool should I use, like listbox or what. Thanks in advance!
Update!
I have a code for selecting multiple excel files. What I need now is how to merge the files that I selected.
Dim FileNames As Variant
Dim Msg As String
Dim I As Integer
FileNames = Application.GetOpenFilename(MultiSelect:=True)
If IsArray(FileNames) Then
Msg = "You selected:" & vbNewLine
For I = LBound(FileNames) To UBound(FileNames)
Msg = Msg & FileNames(I) & vbNewLine
Next I
MsgBox Msg
tbPath.Value = Msg
Else
MsgBox "No files were selected."
End If
Well here is my code... hope this help you.
Sub mergeAllFiles()
Dim This As Workbook 'Store the book with the macro
Dim TmpB As Workbook 'store the book that has the sheets (one per book)
Dim AllB As Workbook 'book to send all the books
Dim sht As Worksheet 'the only sheet every book
Dim FileNames As Variant
Dim Msg As String
Dim I As Integer
Set This = ThisWorkbook
FileNames = Application.GetOpenFilename(MultiSelect:=True)
If IsArray(FileNames) Then
Workbooks.Add 'add a new book to store all the sheets
Set AllB = ActiveWorkbook
AllB.SaveAs This.Path & "\allSheetsInOne" & SetTimeName & ".xlsx", 51
'The function is to store a different name every time and avoid error
Msg = "You selected:" & vbNewLine
For I = LBound(FileNames) To UBound(FileNames)
Workbooks.Open Filename:=FileNames(I)
Set TmpB = ActiveWorkbook
TmpB.Activate
Set sht = ActiveSheet 'because you say that the book has only one sheet
sht.Copy Before:=AllB.Sheets(Sheets.Count) 'send it to the end of the sheets
TmpB.Close 'we don't need the book anymore
Set TmpB = Nothing 'empty the var to use it again
Set sht = Nothing
Msg = Msg & FileNames(I) & vbNewLine
Next I
MsgBox Msg
tbPath.Value = Msg
Else
MsgBox "No files were selected."
End If
End Sub
Function SetTimeName()
Dim YY
Dim MM
Dim DD
Dim HH
Dim MI
Dim SS
Dim TT
YY = Year(Date)
MM = Month(Date)
DD = Day(Date)
HH = Hour(Now)
MI = Minute(Now)
SS = Second(Now)
TT = Format(YY, "0000") & Format(MM, "00") & Format(DD, "00") & Format(HH, "00") & Format(MI, "00") & Format(SS, "00")
SetTimeName = TT
End Function
Tell me if is need it any improvement.
Use my code from here:
Multi-Select Files and open
Edit the code to suite your requirements.
Sub OPenMultipleWorkbooks()
'Open Multiple .xlsx files
Application.DisplayAlerts = False
Dim wb As Workbook, bk As Workbook
Dim sh As Worksheet
Dim GetFile As Variant, Ws As Worksheet
Set wb = ThisWorkbook
Set sh = wb.ActiveSheet
For Each Sheet In Sheets
If Sheet.Name <> sh.Name Then Sheet.Delete
Next Sheet
ChDrive "C:"
Application.ScreenUpdating = False
GetFile = Application.GetOpenFilename(FileFilter:="XLSX(*.xlsx), *.xlsx", Title:="Open XLSX- File", MultiSelect:=True)
On Error Resume Next
If GetFile <> False Then
On Error GoTo 0
For i = 1 To UBound(GetFile)
Set bk = Workbooks.Open(GetFile(i))
Sheets(1).Move Before:=wb.Sheets(1)
bk.Close True
Next i
End If
End Sub

Excel VBA: Copy cells from specific workbook in loop to another

I am new to VBA and am writing a macro. The purpose is to iterate through a list of spreadsheets (I have two sets saved in the same directory and each set has a specific naming convention). One set is named as "GenLU_xx" and the other is named as "LUZ_Summary_xx". The 'xx' in each name refers to a name e.g. Calgary. So I would have two different spreadsheets for Calgary (LUZ_Summary_Calgary & GenLU_Calgary).
The Macro needs to open each spreadsheet starting with "LUZ" add a value to G1. I have accomplished this first part by modifying code I found here: http://www.thespreadsheetguru.com/the-code-vault/2014/4/23/loop-through-all-excel-files-in-a-given-folder
The macro asks the user to identify the directory the spreadsheets are stored in and then loops through ones starting with "LUZ*".
The code is:
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "LUZ*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(fileName:=myPath & myFile)
'Add GEN_LU_ZN to column G1
wb.Worksheets(1).Range("G1").Value = "GEN_LU_ZN"
'Save and Close Workbook
wb.Close SaveChanges:=True
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
What I need for it to do from this point is copy two specific columns from each of the spreadsheets starting with "GenLU" and paste them into sheet 2 of the corresponding spreadsheet.
For example column C & E need to be copied from "GenLU_Calgary_2008" to the second sheet in the corresponding spreadsheet "LUZ_Summary_Calgary_2015". The code needs to somehow match up the spreadsheets using the name (in this case Calgary) and it needs to do this for all the spreadsheets.
Sorry for the extremely long question, but I'm hoping some can help a VBA newb out. I've searched quite a bit and while I have found the code to copy from sheet to sheet or workbook to workbook I am having trouble achieving what I need to. Any help will be much appreciated!
It is hard to test something without having any files, but you can try the following as part of your code:
Dim i As Integer
Dim wb1 As Workbook, wb2 As Workbook
Dim MyAr() As String: MyAr = Split("Calgary,XXX,YYY", ",")
For i = LBound(MyAr) To UBound(MyAr)
Do While myFile <> ""
If myFile Like "GenLU" & "*" & MyAr(i) Then
Set wb1 = Workbooks.Open(Filename:=myPath & myFile)
Exit Do
End If
Loop
Do While myFile <> ""
If myFile Like "LUZ_Summary" & "*" & MyAr(i) And Not wb1 Is Nothing Then
Set wb2 = Workbooks.Open(Filename:=myPath & myFile)
wb2.Worksheets(1).Columns(3).Value = wb1.Worksheets(1).Columns(3).Value
wb2.Worksheets(1).Columns(5).Value = wb1.Worksheets(1).Columns(5).Value
wb1.Close
wb2.Save
wb2.Close
Exit Do
End If
Loop
Set wb1 = Nothing
Next i
Note that you did not provide information which Worksheet you are working on, so I assume its always Worksheets(1). Column C = Columns(3). MyAr() is a String array to store the countries.

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.