I found this code here on StackOverflow:
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Please select the file to kill his non colored cells"
.Filters.Add "Excel", "*.xls"
.Filters.Add "All", "*.*"
If .Show = True Then
txtFileName = .SelectedItems(1)
End If
End With
I know this code should select a file in FileDialog.
However, once I have chosen the .xls file, how do I manipulate the file? In other words, where is my file object for me to manipulate?
I would like someone to continue this code to make some simple manipulation on the workbook so I could learn how to do those simple things on a workbook that I opened.
There are two approaches for you (I prefer using first one). In both approaches wb variable stores opened workbook. I commented code in details, but if you have some questions - ask:)
First approach:
Sub test1()
Dim xlFileName
Dim wb As Workbook
xlFileName = GetOpenFilename("Excel (*.xls*),*.xls*", 1, _
"Please select the file to kill his non colored cells")
'if user pressed CANCEL - exit sub
If xlFileName = False Then
MsgBox "User pressed CANCEL"
Exit Sub
End If
'Tries to open workbook with choosen file name
On Error Resume Next
Set wb = Application.Workbooks.Open(xlFileName)
On Error GoTo 0
'If we can't find workbook with choosen path, exit Sub
If wb Is Nothing Then
MsgBox "Can't find file"
Exit Sub
End If
'your code here
wb.Worksheets("Sheet1").Range("A1").Value = "test"
'close workbook with saving changes
wb.Close SaveChanges:=True
Set wb = Nothing
End Sub
Second approach:
Sub test()
Dim xlFileName As String
Dim fd As Office.FileDialog
Dim wb As Workbook
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Please select the file to kill his non colored cells"
.Filters.Add "Excel", "*.xls*"
.Filters.Add "All", "*.*"
If .Show Then
xlFileName = .SelectedItems(1)
Else
'if user pressed CANCEL - exit sub
MsgBox "User pressed CANCEL"
Exit Sub
End If
End With
'Tries to open workbook with choosen file name
On Error Resume Next
Set wb = Workbooks.Open(xlFileName)
On Error GoTo 0
'If we can't find workbook with choosen path, exit Sub
If wb Is Nothing Then
MsgBox "Can't find file"
Exit Sub
End If
'your code here
wb.Worksheets("Sheet1").Range("A1").Value = "test"
'close workbook with saving changes
wb.Close SaveChanges:=True
Set wb = Nothing
End Sub
Here's an example:
Dim wb As Workbook
Dim ws As Worksheet
Dim r As Range
Set wb = Workbooks.Open(txtfilename) ' the file path you selected in FileDialog
Set ws = wb.Worksheets(1)
Set r = ws.Cells(1, 1)
With r
.Value = "Hello world!"
.Interior.Color = RGB(255,20,20) 'bright red
End With
Related
I'm trying to verify that a sheet exists in my workbook. It will confirm if the sheet name in the workbook exists in my array. If it does not exist then a new worksheet will be added and renamed based on the array. If it does exist, I want the code to continue with checking the next worksheet name.
This is what I have so far but my last array value "Test 7" won't pop up in my new worksheets added. It will only show "Test7" as the new name. Please help!
Dim SheetNames() As Variant
SheetNames()= Array("Test1","Test2","Test3","Test4","Test5","Test6","Test7")
For n =LBound(SheetNames) To UBound(SheetNames)
On Error Resume Next
If Not Worksheets(SheetNames(n)).Name=SheetNames(n) Then
Set cws = wb.Worksheets.Add(After:=ws)
End If
Next
You should cancel the On Error Resume Next as soon as you no longer need it, or you may be hiding unexpected problems in the rest of your code.
Sub tester()
Dim SheetNames() As Variant, ws As Worksheet, wb As Workbook, n As Long
SheetNames() = Array("Test1", "Test2", "Test3", _
"Test4", "Test5", "Test6", "Test7")
Set wb = ThisWorkbook 'for example
For n = LBound(SheetNames) To UBound(SheetNames)
Set ws = Nothing 'reset ws to Nothing
On Error Resume Next 'ignore errors
Set ws = wb.Worksheets(SheetNames(n)) 'try to set `ws`
On Error GoTo 0 'stop ignoring errors
If ws Is Nothing Then 'got a sheet?
Set ws = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
ws.Name = SheetNames(n)
End If
Next
End Sub
Add Missing Worksheets
Option Explicit
Sub AddMissingWorksheets()
Dim SheetNames(): SheetNames = Array( _
"Test1", "Test2", "Test3", "Test4", "Test5", "Test6", "Test7")
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sh As Object, SheetName
For Each SheetName In SheetNames
On Error Resume Next
Set sh = wb.Sheets(SheetName)
On Error GoTo 0
If sh Is Nothing Then ' sheet doesn't exist
wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name = SheetName
Else ' sheet exists
Set sh = Nothing ' reset for the next iteration
End If
Next SheetName
MsgBox "Missing worksheets added.", vbInformation
End Sub
I'm working on a macro that loops through all files in a folder, changes formulas that point to other workbooks to values, and saves and closes each file. I've merged two pieces of code from Ron de Bruin into the below macro. His code to break links and change to values works perfectly when it isn't in the loop but when I run this macro the files then don't have the info, they instead return "#N/A". What am I doing wrong?
Sub Formulas()
Const strSavePath As String = “MyFilePath"
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String, Fnum As Long
Dim mybook As Workbook
Dim CalcMode As Long
Dim sh As Worksheet
Dim ErrorYes As Boolean
Dim Path1 As Range
Set Path1 = ThisWorkbook.Worksheets("Monthly Reporting").Range("E2")
Dim WorkbookLinks As Variant
Dim i As Long
MyPath = strSavePath & Path1 & "\"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
'Change cell value(s) in one worksheet in mybook
WorkbookLinks = mybook.LinkSources(Type:=xlLinkTypeExcelLinks)
If IsArray(WorkbookLinks) Then
For i = LBound(WorkbookLinks) To UBound(WorkbookLinks)
mybook.BreakLink _
Name:=WorkbookLinks(i), _
Type:=xlLinkTypeExcelLinks
Next i
Else
MsgBox "No Links to other workbooks"
End If
If Err.Number > 0 Then
ErrorYes = True
Err.Clear
'Save and close mybook
mybook.Close savechanges:=True
End If
On Error GoTo 0
Else
'Not possible to open the workbook
ErrorYes = True
End If
Next Fnum
End If
If ErrorYes = True Then
MsgBox "There are problems in one or more files, possible problem:" _
& vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
End If
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
My Access database is split into back and front-end.
I have created an Access form in the front-end that contains a textBox, a Browser button and a Relink button.
When I click Browse, file manager pops up to choose my .mdb file. After the file is choosen, the path to the file is displayed into the textBox.
What I want is when I press Relink button, it should take the path from textBox and link my back-end file to my front end.
Here is my code so far:
'browse button
Private Sub browseBtn_Click()
Dim objDialog As Object
set objDialog = Application.FileDialog(3)
With objDialog
.show
.AllowMultiSelect = False
If .SelectedItems.Count = 1 Then
'textFiled displays the path
Me.textField = .SelectedItems(1)
End If
End With
End Sub
'relink button
Private Sub linkBtn_Click()
Dim newConnection As String
Dim currentPath As String
currentPath = Me.textField
Dim tblDef As TableDef
tblDef.Connect = newConnection
tblDef.RefreshLink
End Sub
What is wrong with this?
I've figure it out in the end, here is the full code:
Private Sub browseBtn_Click()
Dim objDialog As Object
Set objDialog = Application.FileDialog(3)
With objDialog
.title = "Please select the backend file"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 1 Then
Me.textField = .SelectedItems(1)
End If
End With
End Sub
Private Sub linkBtn_Click()
RefreshLinks (Me.textField)
End Sub
Public Function RefreshLinks(strFilename As String)
Dim dbs As dao.Database
Dim tdf As TableDef
Set dbs = CurrentDb
For Each tdf In dbs.TableDefs
If Len(tdf.Connect) > 0 Then
tdf.Connect = ";DATABASE=" & strFilename
Err = 0
On Error Resume Next
tdf.refreshlink
If Err <> 0 Then
RefreshLinks = False
Exit Function
End If
End If
Next tdf
RefreshLinks = True
End Function
I take a bunch of .CSV files from a server, open them and save them to another server as .XLSX. My issue is with:
'Get the folder object associated with the directory
Set objPickup = objFSO.GetFolder(pickUp)
Set objDropoff = objFSO.GetFolder(Dropoff)
I keep getting an error and i'm guessing it's because I am pulling in an array pickUp.
Sub ListfilesAndMove()
'List all files in selected folder
Dim objFSO As Object, objPickup As Object, objDropoff As Object, objFile As Object
Dim wb As Workbook, Dropoff As String, pickUp As Variant
Dim LastRowMonthly46 As Long, b As Long, c As Long
Dim ADay As Integer, AMonth As Integer, AYear As Integer, myDate As Date
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim ws As Worksheet: Set ws = ActiveSheet
Dim B3 As Range: Set B3 = ws.Range("B3")
Dim B26 As Range: Set B26 = ws.Range("B26")
Worksheets("Menu").Activate 'Go to worksheet Menu
'Make variable Pickup equal to value of B3
With Application
pickUp = .Transpose(ws.Range(B3, B26))
End With
Dim i As Long
For i = LBound(pickUp) To UBound(pickUp)
Debug.Print pickUp(i)
Next i
Dropoff = ActiveSheet.Range("B28").Value
Worksheets("Report").Activate 'Go to worksheet Report
Worksheets("Report").Visible = True
Worksheets("Menu").Visible = False
'Get the folder object associated with the directory
Set objPickup = objFSO.GetFolder(pickUp)
Set objDropoff = objFSO.GetFolder(Dropoff)
'Set values for cells A1,B1 and C1 and align text
Worksheets("Report").Range("A1").Value = "The files found in " & objPickup.Name & " are:"
Worksheets("Report").Range("A1").VerticalAlignment = xlCenter
Worksheets("Report").Range("A1").HorizontalAlignment = xlLeft
Worksheets("Report").Range("B1").Value = "Processed Yes/No"
Worksheets("Report").Range("B1").HorizontalAlignment = xlCenter
Worksheets("Report").Range("C1").Value = "New File Location"
Worksheets("Report").Range("C1").VerticalAlignment = xlCenter
Worksheets("Report").Range("C1").HorizontalAlignment = xlLeft
'Loop through the Files collection
Application.DisplayAlerts = False
For Each objFile In objPickup.Files
Worksheets("Report").Cells(Worksheets("Report").UsedRange.Rows.Count + 1, 1).Value = objFile.Name
'Open and Save File
Dim Filename As String
Filename = objFile
If Right(Filename, 4) = ".csv" Then
Application.ScreenUpdating = False
Set wb = Application.Workbooks.Open(Filename)
File_name = ActiveWorkbook.Name
File_name2 = ActiveWorkbook.Name
FileLength = Len(File_name2)
File_name2 = Left(File_name2, FileLength - 4)
ActiveWorkbook.ActiveSheet.Name = "Sheet1" 'Rename sheet
With wb 'Save File
'save file to dropoff location
.SaveAs (objDropoff & "\" & File_name2 & ".xlsx"), FileFormat:=xlOpenXMLWorkbook, ConflictResolution:=xlLocalSessionChanges
.Close SaveChanges:=False 'close file
End With
Dim FSO As Object
Set FSO = CreateObject("scripting.filesystemobject")
'Add Processed Comment
Worksheets("Report").Cells(Worksheets("Report").UsedRange.Rows.Count, 2).Value = "Yes"
'Add location of new File
Worksheets("Report").Cells(Worksheets("Report").UsedRange.Rows.Count, 3).Value = objDropoff
Else
Worksheets("Report").Cells(Worksheets("Report").UsedRange.Rows.Count, 2).Value = "No"
End If
Next
Application.DisplayAlerts = True
'Apply wrap text to B1
Worksheets("Report").Range("B1").WrapText = True
Worksheets("Report").Columns("A:C").AutoFit
'Clean up!
Set objPickup = Nothing
Set objDropoff = Nothing
Set objFile = Nothing
Set objFSO = Nothing
End Sub
I'm not sure why all that code is necessary; based on the explanation of what you need to do, you should only need to run two lines of code for each file:
one to open the .CSV:
Workbooks.OpenText "C:\yourPath\yourFile.csv", 65001, 1, , , , True
and one to save as .XLSX:
ActiveWorkbook.SaveAs "C:\yourPath\yourFile.xlsx", xlOpenXMLWorkbook
I don't memorize syntax for rarely used commands like this; instead I let Excel write the code for me using the Macro Recorder. I do the task once and then clean up the code that Excel generates (which resulted in the examples above).
More Information:
MSDN : Workbooks.OpenText Method
MSDN : Workbook.SaveAs Method
MSDN : Recording a Macro to Generate Code
MSDN : Revising Recorded VBA Macros
I am new in Access been trying this for over 3days now. im tyingin to create a module or anything that when a press a button from a form the module will show a file dialog. get the .txt file and insert it into a table
here is how far i have got
Private Sub FileUpload()
'Requires reference to Microsoft Office 12.0 Object Library.
Dim fDialog As Office.FileDialog
Dim varFile As Variant
Const MyFile = "TXT_Import_Spec" 'change to suit
'Clear listbox contents.
'Me.FileList.RowSource = ""
'Set up the File Dialog.
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
'Allow user to make multiple selections in dialog box.
.AllowMultiSelect = False
'Set the title of the dialog box.
.Title = "Please choose FM16 text files"
'Clear out the current filters, and add our own.
.Filters.Clear
.Filters.Add ".txt FM16 Files", "*.TXT"
.Show
obJaces
'Import Myfile
DoCmd.TransferText acImportDelim, "TXT_Import_Spec", "DM1", "MyFile", False
'Delete old records from Tbl_Import
'CurrentDb.Execute "DELETE * FROM DM1"
'Add new records to Tbl_Import
CurrentDb.Execute "INSERT INTO DM1 SELECT * FROM MyFile WHERE MyFile.JobNo IN (SELECT MyFile.JobNo FROM MyFile LEFT JOIN Tbl_Import ON MyFile.JobNo = Tbl_Import.JobNo WHERE Tbl_Import.JobNo Is Null)"
'Delete Myfile Table
CurrentDb.Execute "DROP TABLE MyFile"
End With
End Sub
been a stress full week. will appreciate any help.
#DonGeorge I have manage to get the script working please check the script below but the problem is its taking for ever. because the txt file has like 900,000 records.
so what i did to avoid overflow error is the script to show notification in every 100,000 records uploaded. but that takes like 5 mins for a good computer.
Option Compare Database
Sub uploadData()
On Error GoTo 11:
Dim strFile As String
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim cnt As Double
strFile = GetFile
If strFile <> "" Then
Set db = CurrentDb()
Set rs1 = db.OpenRecordset("BM1")
Dim firstLine As Boolean
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(strFile)
firstLine = False
msg = MsgBox("Do you want to delete all records from BM1 before loading ?", vbCritical + vbYesNo, "Upload File")
If msg = vbYes Then
DoCmd.SetWarnings False
DoCmd.RunSQL "delete * from BM1"
DoCmd.SetWarnings True
End If
Do Until objFile.AtEndOfStream
strEmployee = objFile.ReadLine
If firstLine = True Then
arrEmployee = Split(strEmployee, ",")
If UBound(arrEmployee) = 20 Then
rs1.AddNew
For i = 0 To rs1.Fields.Count - 1
rs1.Fields(i).Value = Replace(arrEmployee(i), """", "")
Next
rs1.Update
End If
Else
firstLine = True
End If
cnt = cnt + 1
If cnt Mod 100000 = 0 Then
MsgBox "Records Added " & cnt
End If
Loop
rs1.Close
MsgBox "Records Upload Completed"
End If
Exit Sub
11:
MsgBox Err.Description
End Sub
Function GetFile() As String
Dim f As Object
Set f = Application.FileDialog(3)
Dim varfile As Variant
f.AllowMultiSelect = False
f.Filters.Clear
f.Filters.Add "Text File", "*.txt"
f.Show
For Each varfile In f.selecteditems
GetFile = varfile
Exit For
Next varfile
End Function