I have the following code
Private Sub btnOpenTemplate_Click()
Dim c As Range
Dim fd As Office.FileDialog, directory As String, fileName As String
Set c = Settings.Range("A1")
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Âûáåðèòå øàáëîí ÏÌÈ."
.Filters.Clear
.Filters.Add "Word 2003", "*.doc?"
If .Show = True Then
fileName = .SelectedItems(1)
End If
End With
If fileName = "" Then
Exit Sub
End If
If Dir(fileName, vbNormal) <> "" Then
If c.Worksheet.OLEObjects.Count > 0 Then
c.Worksheet.OLEObjects(1).Delete
End If
Settings.OLEObjects.Add fileName:=fileName, Link:=False, DisplayAsIcon:=True
End If
Settings.Range("A2").Value = fileName
lblTemplateFile.Caption = fileName
End Sub
Whenever it is executed, the workbook gets damaged and Excel is unable to repair and save it. What could be wrong? What I mean is that the workbook works fine just until I embed an object (Word doc) into it via the macro. Then it gets damaged.
Related
How may I tweak the code below to 1) Only Save the Active Worksheet (instead of entire Workbook) and 2) Save the file as an Excel Binary file?
I'm breaking my head over this... Many thanks
Dim FileName As String
FileName = Range("B2").Value
Dim fPth As Object
Set fPth = Application.FileDialog(msoFileDialogSaveAs)
With fPth
.initialFilename = FileName
.Title = "Save your File"
.FilterIndex = 2
.InitialView = msoFileDialogViewList
If .Show <> 0 Then
ThisWorkbook.SaveAs FileName:=.SelectedItems(1), FileFormat:=xlExcel12
End If
I would like to save Sheet1 of ActiveWorkbook in a new book, the path will be given by the user and the name will be given by me, and then close the new book.
First, I create the copy of the sheet in a new book: ActiveWorkbook.Sheets("Sheet1").Copy and then call FileDialog (msoFileDialogSaveAs). But this saves ActiveWorkbook with the new name and leaves the newly created book unsaved and Workbooks(FileName & ".xlsm").Close gives error.
What am I doing wrong?
Option Explicit
Sub Save_As()
ActiveWorkbook.Sheets("Sheet1").Copy
Dim Time As String
Time = Format(Now, "ddmmyyyy_hhmmss")
Dim FileName As String
FileName = ActiveWorkbook.Name & "_" & Time
Dim ObFD As FileDialog
Set ObFD = Application.FileDialog(msoFileDialogSaveAs)
With ObFD
.Title = "Choose a path and export this file"
.ButtonName = "E&xport"
ObFD.InitialFileName = "C:\" & FileName
ObFD.FilterIndex = 2
ObFD.InitialView = msoFileDialogViewDetails
If ObFD.Show <> 0 Then
ObFD.Execute
Application.DisplayAlerts = False
Workbooks(FileName & ".xlsm").Close
Application.DisplayAlerts = True
End If
End With
End Sub
First retrieve the path and filename using the SelectedItems property of the FileDialog object. Then save the workbook using the SaveAs method of the Workbook object, and then close it using the Close method of the Workbook object.
Other Suggestions
1) Turn ScreenUpdating off at the beginning of your macro so that everything happens in the background, and makes things more efficient. Then turn it back on again at the end.
2) Prompt the user to select a path before creating a copy of the worksheet. Otherwise, you'll be left with a newly created workbook if the user cancels.
3) There's no need to specify ObFD within the With/End With statement, since the statement already refers to ObFD. So, for example, you should use .InitialFileName instead of ObFD.InitialFilename.
4) Avoid naming your vairable Time, since VBA has a function named Time.
Here's your macro, which has been amended accordingly...
Option Explicit
Sub Save_As()
Application.ScreenUpdating = False
Dim MyTime As String
MyTime = Format(Now, "ddmmyyyy_hhmmss")
Dim FileName As String
FileName = ActiveWorkbook.Name & "_" & MyTime
Dim ObFD As FileDialog
Set ObFD = Application.FileDialog(msoFileDialogSaveAs)
With ObFD
.Title = "Choose a path and export this file"
.ButtonName = "E&xport"
.InitialFileName = "C:\" & FileName
.FilterIndex = 2
.InitialView = msoFileDialogViewDetails
.Show
If .SelectedItems.Count = 0 Then
Exit Sub
Else
Dim PathAndFilename As String
PathAndFilename = .SelectedItems(1)
End If
End With
ActiveWorkbook.Sheets("Sheet1").Copy
ActiveWorkbook.SaveAs FileName:=PathAndFilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled
ActiveWorkbook.Close savechanges:=False
Application.ScreenUpdating = True
End Sub
Let's say i'm working on workbook A and workbook A produce a .txt file.
I also have workbook B witch contain a table that is ready to receive data from a .txt file.
i want to import the .txt fileproduce by workbook A into workbook B and i want to do so with workbook A
here's my code:
Sub result_template()
Dim FL As String
Dim wb As Workbook
Dim restemplate As Object
With Application.FileDialog(msoFileDialogFilePicker) '
.Title = "Select the log file" 'Open the file explorer
.InitialFileName = ThisWorkbook.path & "\" 'for you to select
.InitialView = msoFileDialogViewDetails 'the file you want
.AllowMultiSelect = False 'to format
.Show
If Not .SelectedItems(1) = vbNullString Then Sheets(5).Cells(36, 16).Value = .SelectedItems(1)
End With
With Application.FileDialog(msoFileDialogFilePicker) '
.Title = "Select the result template" 'Open the file explorer
.InitialFileName = ThisWorkbook.path & "\" 'for you to select
.InitialView = msoFileDialogViewDetails 'the file you want
.AllowMultiSelect = False 'to format
.Show
If Not .SelectedItems(1) = vbNullString Then FL = .SelectedItems(1)
Set restemplate = wb.OpenText(FL, 3, xlDelimited, True, True)
'Code to copy the contents of the .txt file to your table
ActiveWorkbook.Close Savechanges:=True filename:="result" & Date
End With
End Sub
I have a syntaxe error on ActiveWorkbook.Close
and have Object variable not set error on Set restemplate = wb.OpenText(FL, 3, xlDelimited, True, True)
what I'm I doing wrong?
I have a worbook that copy information from differents workbooks.
To open these workbooks I use the code below:
Dim nomearq As String
Dim nomearq2 As String
nomearq = Application.GetOpenFilename
Workbooks.Open Filename:=nomearq
nomearq2 = ActiveWorkbook.Name
So, I was trying to not allow the macro run if the selected file isn't a excel file:
If Not Right(nomearq, 4) = ".xls" Or Right(nomearq, 5) = ".xlsm" Then
MsgBox "Arquivo incompatível"
Exit Sub
But the xlsm files aren't openning. I can't wondering why.
As an alternative, you can limit the user to only being able to select Excel files, like so:
Sub tgr()
Dim nomearq As Variant
nomearq = Application.GetOpenFilename("Excel Files, *.xl??") 'This specifies that it can ONLY open Excel files
If VarType(nomearq) = vbBoolean Then Exit Sub 'Pressed cancel
With Workbooks.Open(nomearq)
'do stuff with the workbook here
MsgBox "opened " & nomearq
.Close SaveChanges:=False 'Close the opened workbook when you're done with it
End With
End Sub
The problem is with your Or logic:
If Not Right(nomearq, 4) = ".xls" Or Right(nomearq, 5) = ".xlsm" Then
This statement is actually two statements, add parentheses to see what's happening:
If (Not Right(nomearq, 4) = ".xls") Or (Right(nomearq, 5) = ".xlsm") Then
You can add the appropriate Not logic, or, instead of using Application.GetOpenFilename you should use Application.FileDialog which has parameters that allow you to restrict the file type.
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm; *.xlsb", 1
.FilterIndex = 1
.Show
If .SelectedItems.Count > 0 Then
nomearq = .SelectedItems(0)
End If
End With
If you don't want to use FileDialog, then you can make your logic a bit more foolproof:
Dim extPos as Integer
extPos = InstrRev(nomearq, ".")
If Not Right(nomearq, extPos) Like ".xls*" Then
This should handle XlS, XLSM, XLSX, XLSB etc. file extensions.
I am trying to copy a sheet from one file and then paste it to an established tab in about 6 files in an established folder. I have this code, but it only works for the first file in the folder. It is also creating a blank workbook for some reason. Any suggestions?
Sub LoopThroughFiles()
Dim wbk As Workbook
Dim Filename As String
Dim FirstFile As String
Dim FileDirectory As String
Dim x As Workbook
Set x = Workbooks.Open("test.xlsx")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder"
Exit Sub
Else
FileDirectory = .SelectedItems(1) & "\"
End If
End With
Set wbk = Workbooks.Add
Filename = Dir(FileDirectory)
FirstFile = Filename
Do Until Filename = ""
Dim new_wb As Workbook
Set new_wb = Workbooks.Open(FileDirectory & Filename)
If FirstFile = Filename Then
x.Sheets("report").UsedRange.Copy
new_wb.Sheets("roster").Range("a1").PasteSpecial
End If
new_wb.Close savechanges:=True
Filename = Dir
Loop
MsgBox "All store totals have been added"
End Sub
Sub LoopThroughFiles_Paste_Roster()
Dim wbk As Workbook 'New workbook the data is added to
Dim Filename As String
Dim FirstFile As String
Dim FileDirectory As String
Dim x As Workbook
Dim y As Workbook
Set x = Workbooks.Open("Copy Doc 1")
Set y = Workbooks.Open("Copy Doc 2")
'display the folder picker dialog box so user can select a folder
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder"
Exit Sub
Else
FileDirectory = .SelectedItems(1) & "\"
End If
End With
'retrieve the name of the first file in the folder using Dir
Filename = Dir(FileDirectory)
FirstFile = Filename
'Loop through all the files in the folder
'open the file
Do Until Filename = ""
Set wbk = Workbooks.Open(FileDirectory & Filename, UpdateLinks:=False, Password:="Password123")
With wbk
x.Sheets("report").UsedRange.Copy
wbk.Sheets("roster").Range("a1").PasteSpecial
y.Sheets("Setup").UsedRange.Copy
wbk.Sheets("PTO Taken and Req").Range("a1").PasteSpecial
End With
'save and close the file
'get the next file in the folder
wbk.Close savechanges:=True
Filename = Dir
Loop
MsgBox "All pages have been updated"
End Sub