I am creating a VBA program that will copy one column from one file to another.
The current code works, but I wish to change it to where a prompt will come up and ask the user for the file location and name / extension. That input will be imported as the file location for the Workbooks.Open function and go from there.
How do I create a prompt to ask for the user to input the file location and name for the desired excel file, and have it input in the Workbooks.Open function?
Code:
Sub Macro1()
Dim wb1 As Workbook
Dim wb2 As Workbook
MsgBox "Now converting data from Incident Data to Specific Data "
'Set it to be the file location, name, and extension of the Call Data CSV
Set wb1 = Workbooks.Open("Z:\xxxx\Call Data - Copy.csv")
'Set it to be the file location of the Working File
Set wb2 = Workbooks.Open("Z:\xxxx\Working File.xlsx")
wb1.Worksheets(1).Columns("E").Copy wb2.Worksheets(1).Columns("A")
wb1.Worksheets(1).Columns("I").Copy wb2.Worksheets(1).Columns("Q")
wb1.Worksheets(1).Columns("AE").Copy wb2.Worksheets(1).Columns("R")
wb1.Worksheets(1).Columns("BD").Copy wb2.Worksheets(1).Columns("F")
wb2.Close SaveCahnges:=True
wb1.Close SaveChanges:=True
End Sub
I would go with FileDialog to select an input file:
Dim fDialog As FileDialog, result As Integer
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
fDialog.AllowMultiSelect = False
fDialog.title = "Select a file"
fDialog.InitialFileName = "C:\"
fDialog.Filters.Clear
fDialog.Filters.Add "Excel files", "*.xlsx"
'Show the dialog. -1 means a file has been successfully selected
If fDialog.Show = -1 Then
Debug.Print fDialog.SelectedItems(1)
End If
For saving you can refer to this post
EDIT:
To use it in Workbooks.Open you just do something like the following:
Dim fname As String
If fDialog.Show = -1 Then
fname=fDialog.SelectedItems(1)
Else
MsgBox("Filename selection error")
Exit Sub
End If
Set wb1 = Workbooks.Open(fname)
Related
I am running into issues while attempting to open an additional Excel file using VBA in Excel 2016. It matters not whether the file is in the same directory. I am thinking it has something to do with a default setting in Excel 2016 that is blocking the search? The Macro functioned in Excel 2010.
Private Sub CommmandButton_Click()
Dim source As String
Dim temp As Workbook
source = InputBox("Enter source")
Set temp = Workbooks.Open(source)
end sub
Here is an example solution using the FileDialog object
Private Sub CommmandButton_Click()
Dim fDialog As FileDialog, _
wb As Excel.Workbook
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
.AllowMultiSelect = False
.Title = "Select a file"
.InitialFileName = "C:\"
.Filters.Clear
' Prevent Error by specifying that the user must use an excel file
.Filters.Add "Excel files", "*.xlsx,*.xls,*.xlsm"
End With
If fDialog.Show = -1 Then
Set wb = Excel.Workbooks.Open(fDialog.SelectedItems(1))
Else
End ' Cleanly exit the Macro if the user cancels
End If
End Sub
You are allowing users to do more than point and click. This is asking for trouble. Instead:
Private Sub CommmandButton_Click()
Dim source As String
Dim temp As Workbook
source = Application.GetOpenFilename()
Set temp = Workbooks.Open(source)
end sub
This code can be further enhanced to:
1. pre-select the initial path
2. set the file-type(s)
3. give guidance
4. gracefully handle cancellations
I have a macro that will copy data from a csv file to my excel file and works great if the file name is the same every time. That's where the problem lies: it's not the same name every time.
I need the script to allow a user to select the csv file. Then, the code to allow it to copy. This is what I have:
Sub importmix()
Worksheets("mixdata").Range("A1:P300").Clear
'## Open workbooks first:
Set X = Workbooks.Open("C:\test\mix.csv")
'## Set values between workbooks
Workbooks("2.xlsm").Worksheets("mixdata").Range("A1:K300").Value = _
Workbooks("mix.csv").Worksheets("mix").Range("C1:M300").Value
'##Close x:
X.Close False
End Sub
I think you are looking for something like this:
Sub test()
Dim intResult As Integer
Dim fD As FileDialog
Set fD = Application.FileDialog(msoFileDialogFilePicker)
With fD
.Title = "Select a Path"
.AllowMultiSelect = False
.Show
End With
importmix fD.SelectedItems(1)
End Sub
Sub importmix(path As String)
Worksheets("mixdata").Range("A1:P300").Clear
'## Open workbooks first:
Set X = Workbooks.Open(path)
'## Set values between workbooks
Workbooks("2.xlsm").Worksheets("mixdata").Range("A1:K300").Value = _
Workbooks(Dir(path)).Worksheets(Dir(Replace(UCase(path), ".csv", ""))).Range("C1:M300").Value
'##Close x:
X.Close False
End Sub
Dir(path) gives you the file name. A csv automatically opens a sheet with the name of the file without the extension so removing the .csv takes care of that.
Should be able to use:
Dim intResult as integer
'Dialogue box name
Application.FileDialog(msoFileDialogFolderPicker).Title = "Select a Path"
'The dialog is displayed to the user
intResult = Application.FileDialog(msoFileDialogFolderPicker).Show
So I have been going around in circles trying to find an answer to what should be a basic file combination.
I have a weeks worth of CSV files generated.
I need to combine the files into a single worksheet with the data stacked
Original file has 2 of the columns that are date and time combined (d/mm/yyyy h:mm:ss)
I have my VBA code combining the data as required but the time formatting is screwed in the master file (d/mm/yyyy h:mm)
Can someone help please with my code :(
Option Explicit
Sub ImportCSVsWithReference()
'Summary: Import all CSV files from a folder into a single sheet
' adding a field in column A listing the CSV filenames
Dim wbCSV As Workbook
Dim wsMstr As Worksheet: Set wsMstr = ThisWorkbook.Sheets("MasterCSV")
Dim fCSV As String
Dim fList As String
Dim fName As String
Dim fd As FileDialog
Dim FileChosen As Integer
Dim FileName As String
Dim i As Integer
Dim wbCSVDisplayOrder As Long
Dim M As Long
'Select the correct files for merge
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'use the standard title and filters, but change the
'initial folder
fd.InitialFileName = "C:\RTVis\OT"
fd.InitialView = msoFileDialogViewList
'allow multiple file selection
fd.AllowMultiSelect = True
FileChosen = fd.Show
If FileChosen = -1 Then
'open each of the files chosen
For i = 1 To fd.SelectedItems.Count
Workbooks.Open fd.SelectedItems(i)
Next i
End If
'clear master page of previous data
If MsgBox("Clear the existing MasterCSV sheet before importing?", vbYesNo, "Clear?") _
= vbYes Then wsMstr.UsedRange.Clear
Application.ScreenUpdating = False 'speed up macro
'Combine files
'start the CSV file listing
fCSV = Dir(fName & "*.csv")
Do While Len(fCSV) > 0
'open a CSV file
Set wbCSV = Workbooks.Open(fName & fCSV)
'copy date into master sheet and close source file
ActiveSheet.UsedRange.Copy wsMstr.Range("A" & Rows.Count).End(xlUp).Offset(0)
wbCSV.Close False
'ready next CSV
fCSV = Dir
Loop
Application.ScreenUpdating = True
End Sub
If I understand you correctly, your problem is with the date/time formatting being munged by Excel when you open the file, but the parsing works properly otherwise.
When Excel sees what looks like a date, it will try to interpret it in accord with your Windows Regional Settings. So if the date in the file is DMY, and your settings at MDY, the dates will not be interpreted properly.
Workaround 1: Change your windows regional settings to match those in the CSV file
Workaround 2: Use the QueryTables method. You can get the VBA equivalent by using the macro recorder and executing, from native Excel, Data ► Get External Data ► From Text Files This will allow specification of the date format. But you must be careful about not adding them multiple times but by refreshing them instead or first deleting them and then adding them again.
Workaround 3: Write your own parsing routine to parse the raw data. Probably should use the FileSystemObject if doing this.
Workaround 4: Change the file suffix to something other than .csv, and then use the OpenText method. This requires the least changes to your existing code. You create a new file; import that; then delete it. The code below demonstrates that process, but does NOT do the other things that you want.
If you use 4, you should add some error handling in case the file copy / delete process goes awry. My favorite options would be 2 or 3.
Sample Code
Option Explicit
Sub foo()
Dim WB As Workbook, wbCSV As Workbook, swbCSV As String
Dim sFN As String, sCopyFN
Dim FD As FileDialog
Set WB = ThisWorkbook
Set FD = Application.FileDialog(msoFileDialogFilePicker)
With FD
.AllowMultiSelect = False
.Filters.Add "Text or CSV", "*.txt, *.csv", 1
.Show
sFN = .SelectedItems(1)
End With
'If CSV, remove suffix
sCopyFN = ""
If sFN Like "*.csv" Then
sCopyFN = Left(sFN, Len(sFN) - 4)
FileCopy sFN, sCopyFN
sFN = sCopyFN
End If
Workbooks.OpenText Filename:=sFN, DataType:=xlDelimited, origin:=437, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
FieldInfo:=Array(Array(1, xlDMYFormat), Array(2, xlGeneralFormat))
Set wbCSV = ActiveWorkbook
'Get path as string since it will not be available after closing the file
swbCSV = wbCSV.FullName
'Move the data into this workbook
Dim rCopy As Range, rDest As Range
With WB.Worksheets("sheet1")
Set rDest = .Cells(.Rows.Count, 1).End(xlUp)
End With
Set rCopy = wbCSV.Sheets(1).UsedRange
rCopy.Copy rDest
'must close the file before deleting it
wbCSV.Close False
Kill swbCSV
End Sub
I'm trying to make a merge file script just as this question.
https://stackoverflow.com/a/4148797/1864883
It's working fine, it's copping the files into new worksheets inside the same new workbook.
The only problem is that the colours are not been the same in the target file.
Here is a screenshot comparing input and output:
Here is the macro that I'm running to accomplish the task:
Option Explicit
'Ref: https://stackoverflow.com/a/26474331/1864883
Private Sub MergeFiles()
Dim directory As String, fileName As String, sheet As Worksheet, total As Integer
Dim WrdArray() As String, currentFile As Workbook, thisFile As Workbook, output As Workbook, outputName As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set thisFile = ActiveWorkbook 'Reference for current workbook
directory = thisFile.Sheets("teste1").Cells(2, 2).Value 'Get path of files to merge from cell B2
outputName = thisFile.Sheets("teste1").Cells(3, 2).Value 'Get output file name from cell B3
fileName = Dir(directory & "*.xl??")
Set output = Workbooks.Add 'Create new workbook for output
'Ref: https://stackoverflow.com/a/4148797/1864883
Do While fileName <> ""
Set currentFile = Workbooks.Open(directory & fileName) 'Open file as current file
WrdArray() = Split(fileName, ".") 'Split file name in `.` to get name without extension
For Each sheet In currentFile.Worksheets 'Interate each sheet
currentFile.ActiveSheet.Name = WrdArray(0) 'Changes sheet name to same as file name
sheetsInOutput = output.Worksheets.Count 'Amount of seets in output
currentFile.Worksheets(sheet.Name).Copy after:=output.Worksheets(sheetsInOutput)
GoTo exitFor:
Next sheet
exitFor:
currentFile.Close
fileName = Dir()
Loop
output.Worksheets(1).Delete 'Delete first sheet crated when output created
output.SaveAs fileName:=thisFile.Path & "\" & outputName 'Saves output in same directory as this file
output.Close 'closes output file
'thisFile.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
'Referência: https://stackoverflow.com/a/2051420/1864883
Private Sub Workbook_Open()
Call MergeFiles ' Call your macro
'ActiveWorkbook.Save ' Save the current workbook, bypassing the prompt
'Application.Quit ' Quit Excel
End Sub
PS: I tested with some other files that worked just fine, These file that I'm getting trouble are from Crystal Report.
Read this: https://msdn.microsoft.com/en-us/library/office/ff821660.aspx
You need make sure that both workbooks have same color.
Example:
ThisWorkbook.Colors = Workbooks(2).Colors
So the issue I'm having is we have a schedule program made via excel, that is set to replace all user names and shift times with "####" and where it would normally display names inputs "Contact blah blah for new version." This occured on 1/1/15. For now they can backdate their computer to a date prior to 1/1/15 and once they type a value in to any cell the worksheet runs and all their data re-appears. We have locations across the country that saves the file every two weeks to Wildcardname.xls I'm looking for a way to program a command button that finds the other random name opened workbook, goes to hidden sheet "help" and changes the value of Cell A184 to "01/01/2016" or any date I plug in. Which would remove the "####" issue and replace it with the originally inputed values. The user could then save the file and carry on.
I was browsing through various help boards and found this..prompts a user to select the workbook. This would be the workbook that needs changed.
http://www.excelforum.com/excel-programming-vba-macros/695467-copy-values-from-a-worksheet-to-another-workbook-source-workbook-name-unknown.html
Sub CopyData()
Dim DstRng As Range
Dim DstWkb As Workbook
Dim DstWks As Worksheet
Dim FileFilter As String
Dim Filename As String
Dim SrcRng As Range
Dim SrcWkb As Workbook
Dim SrcWks As Worksheet
Dim SheetName As String
SheetName = "Output Table"
FileFilter = "Excel Workbooks (*.xls), *.xls"
Filename = Application.GetOpenFilename(FileFilter, , "Open Source Workbook")
If Filename = "False" Then
MsgBox "Open Source File Canceled."
Exit Sub
End If
Set SrcWkb = Workbooks.Open(Filename)
Set SrcWks = SrcWkb.Worksheets(SheetName)
Set SrcRng = SrcWks.Range("A2:H20")
FileFilter = "Excel Workbooks (*.xls), *.xls"
Filename = Application.GetOpenFilename(FileFilter, , "Open Destination Workbook")
If Filename = "False" Then
MsgBox "Open Destination File Canceled."
Exit Sub
End If
Set DstWkb = Workbooks.Open(Filename)
Set DstWks = DstWkb.Worksheets(SheetName)
Set DstRng = DstWks.Range("A2:H20")
SrcRng.Copy Destination:=DstRng
End Sub
Can this be modified to accomplish what I want to complete?
I can't post an image yet, so here's a link to a mock up. Before shot of the program on the left, and on the right is what I want it to look like.
http://i528.photobucket.com/albums/dd330/DLN1223/mockup.jpg
Hopefully this description makes since....
Thanks in advance for your help.
This is what I use:
Dim FileToOpen As Variant
Dim WKbook as workbook
FileToOpen = Application.GetOpenFilename("Excel files (*.xlsx),*.xlsx", , "Select Workbook to Open")
If FileToOpen = False Then Exit Sub 'quit on cancel
Set Wkbook = Workbooks.Open(FileToOpen, False, False)
With this, I can the set the value I want, and save changes
Wkbook.Sheets("help").Range("A184")=#1/1/2016#
Wkbook.Close SaveChanges:=True
depending on the filetype, you may need to change Excel files (*.xlsx),*.xlsx to Excel files (*.xls),*.xls