I want to copy the data from a closed file I have selected and see it in the file containing this macro.
I am using Office365.
How can i copy data from this "FullPath" workbook ?
Private Sub PathName()
Dim FullPath As String
On Error GoTo extApp
FullPath = Application.GetOpenFilename(FileFilter:="File Filter," & _
"*.xls;*.doc;*.xlsx;*.mdb;*.ppt;*.pdf", Title:="Please Select A File")
Exit Sub
extApp: Select Case Err.Number
Case 104
MsgBox ("104")
Exit Sub
Case Else
MsgBox "Runtime Error: " & Err.Number & vbNewLine & Err.Description
Stop
Resume
End Select
End Sub
You may try the following code modication, add in your other part of code to make it work as a complete sub:
Private Sub PathName()
Dim FullPath As String
Dim wb As Workbook
Application.DisplayAlerts = False
On Error GoTo extApp
FullPath = Application.GetOpenFilename(FileFilter:="File Filter," & _
"*.xls;*.doc;*.xlsx;*.mdb;*.ppt;*.pdf", Title:="Please Select A File")
Set wb = Workbooks.Open(FullPath, , True)
wb.Worksheets("Sheet1").Range("A1:B" & lastrow).Copy
Sheet1.Range("A1").PasteSpecial xlPasteValues
'
'
'
wb.Close
Application.DisplayAlerts = True
End Sub
Related
I have code that run when file Opens that renames file data in Inputbox using ActiveWorkbook.SaveAs. It works fine under following conditions.
Spreadsheet opened in "File Explorer"
Spreadsheet opened in Excel Browser screen.
When spreadsheet is opened thru Excel Open/Menu, Sub will not save new file at initial Open, but if I run sub after, no issues.
Private Sub Workbook_Open()
'Checks Status of Workbook upon Openning
Dim PON, INP As String
Dim strPath, JC As String
Dim strNewName, NewName As String
INP = Worksheets("CHK").Range("J1").Value
Worksheets("CHK").Range("Q1").Value = "Good"
Worksheets("Form").Select
Worksheets("Form").Range("C4").Select
Call Protect_All_Sheets_Pswrd
If INP = "New" Then
Call Save_PO_File
Else
If INP = "Done" Then
MsgBox "This Check List is COMPLETE!!!!!"
Call Save_PO_File
Else
Call PGUP_PGDN
UserForm2.Show
End If
End If
End Sub
Sub Save_PO_File()
Dim strPath As String
Dim strNewName, NewName As String
1000 On Error GoTo ErrorHandler
Answer = MsgBox("Do You want to start NEW Rental Checklist?", vbQuestion + vbYesNo + vbDefaultButton2)
If Answer = vbYes Then
Worksheets("CHK").Range("S6").Value = 0
PON = InputBox("Please enter PO Number to Start Checklist:", Xpos:=2880, Ypos:=1440)
If Len(PON) > 7 Then
MsgBox "PO number can only be a Maximum of 7 digits"
GoTo 1000
End If
If PON = "" Then
MsgBox "MUST ENTER PO#"
GoTo 1000
End If
strNewName = "Rental Checklist PO " + PON & ".xlsm"
strPath = ActiveWorkbook.Path
NewName = strPath & "\" & strNewName
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=NewName
Application.DisplayAlerts = True
If ActiveWorkbook.Name <> strNewName Then
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=NewName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Application.DisplayAlerts = True
End If
MsgBox strPath & "/" & vbNewLine & vbNewLine & strNewName, , "NEW Workbook Saved As"
Call Clean_Form 'Clear Form
Worksheets("Form").Range("C9").Value = PON 'Input PO #
Worksheets("Form").Range("C4").Select
Call PGUP_PGDN
Else
Call Confirm_ADMIN
End If
Exit Sub
ErrorHandler:
MsgBox "Had Error... Check File Name"
Exit Sub
End Sub
Tried different folders, adding error checking...etc
I have written the following code tied to a command button to prompt the user to define a save path, export the active sheet to PDF and open it, then delete the sheet after it's been exported and activate a different sheet. The code works to completion but right at the end, I get a the following error:
Run-time error '-2147221080 (800401a8)':
Automation error
Below is my code. Any help would be immensely appreciated.
Private Sub ExceptionPrint_Click()
Sheet_Name = ActiveSheet.Name
PDF_Name = "Exception - " & ActiveSheet.Name & ".pdf"
Set File_Dialog = Application.FileDialog(msoFileDialogFolderPicker)
File_Dialog.AllowMultiSelect = False
File_Dialog.Title = "Select the Desired Location"
If File_Dialog.Show <> -1 Then
Exit Sub
End If
PDF_Name = File_Dialog.SelectedItems(1) & "\" & PDF_Name
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=PDF_Name, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
If Sheets("Data").Range("H12").Value = "W1" Then
Sheets("Week 1").Activate
Sheets("Data").Range("H12").Value = ""
Else
Sheets("Week 1").Activate
Sheets("Data").Range("H12").Value = ""
End If
Application.DisplayAlerts = False
Sheets(Sheet_Name).Delete
Application.DisplayAlerts = True
End Sub
I've tried everything I could think of, but I'm not that great with VBA to begin with.
Assign the active sheet to a reference at the start and use that reference throughout the program. Also try to catch early any errors that the user might make.
Option Explicit
Private Sub ExceptionPrint_Click()
Dim wb As Workbook, wsPDF As Worksheet, PDF_Name As String
' validation
Set wb = ThisWorkbook
Set wsPDF = wb.ActiveSheet
With wsPDF
If .Name = "Week 1" Or .Name = "Data" Then
MsgBox "Sheet " & wsPDF.Name & " must not be selected", vbCritical
Exit Sub
ElseIf WorksheetFunction.CountA(.UsedRange) = 0 Then
MsgBox .Name & " is blank", vbCritical
Exit Sub
End If
End With
' select folder
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select the Desired Location"
If .Show <> -1 Then Exit Sub
PDF_Name = .SelectedItems(1) & "\Exception - " & wsPDF.Name & ".pdf"
End With
' print and delete
wsPDF.ExportAsFixedFormat Filename:=PDF_Name, Type:=xlTypePDF, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
Application.DisplayAlerts = False
wsPDF.Delete
Application.DisplayAlerts = True
' finish
With wb
.Sheets("Week 1").Activate
.Sheets("Data").Range("H12").Value = ""
End With
End Sub
I ended up just leaving a "Delete Sheet" button on the sheet in question rather than having it automatically delete. Thank you everyone.
I have previously posted on here about using VBA to loop through a folder and remove known passwords from each workbook therein. Thought I could use the same code and just insert code the removes all sheets except one (by reference to sheet name), but no such luck.
Any VBA pros out there that can help?
Sub loop_sheets_del()
Dim MyFile as String, str As String, MyDir = "[directory]"
MyFile = Dir(MyDir & "*.xlsx")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While Myfile <> ""
Workbooks.Open (MyFile)
If ws.Name <> "name of sheet to keep" Then
ws.Delete
End If
Next ws (error indicates problem is here)
ActiveWorkbook.Close True
End With
MyFile = Dir()
Loop
End Sub
Delete Sheets
In the current setup, the following will delete all sheets except the one named Master in all files with the xls* extension (e.g. xls, xlsx, xlsm: do not use wild characters in the code; it is covered by Instr) in the specified folder F:\Test\2020\64504925 and all of its subfolders.
The Code
Option Explicit
' Run only this sub after you have adjusted the path, the worksheet name
' and the file extension.
Sub loopSubFolders()
Application.ScreenUpdating = False
loopSubFoldersInitialize "F:\Test\2020\64504925", "Master", "xls"
Application.ScreenUpdating = True
MsgBox "Sheets deleted.", vbInformation, "Success"
End Sub
Sub loopSubFoldersInitialize(ByVal FolderPath As String, _
ByVal SheetName As String, _
Optional ByVal FileExtension As String = "")
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
loopSubFoldersRecursion fso, fso.GetFolder(FolderPath), SheetName, _
FileExtension
End Sub
Sub loopSubFoldersRecursion(fso As Object, _
fsoFolder As Object, _
ByVal SheetName As String, _
Optional ByVal FileExtension As String = "")
Dim fsoSubFolder As Object
Dim fsofile As Object
For Each fsoSubFolder In fsoFolder.SubFolders
loopSubFoldersRecursion fso, fsoSubFolder, SheetName, FileExtension
Next
If FileExtension = "" Then
For Each fsofile In fsoFolder.Files
'Debug.Print fsofile.Path
Next
Else
For Each fsofile In fsoFolder.Files
If InStr(1, fso.GetExtensionName(fsofile.Path), _
FileExtension, vbTextCompare) > 0 Then
Dim wb As Workbook
Set wb = Workbooks.Open(fsofile.Path)
deleteSheetsExceptOneByName wb, SheetName
Debug.Print fsofile.Path
wb.Close SaveChanges:=True
End If
Next fsofile
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Deletes all sheets in a workbook except the one specified
' by its name.
' Remarks: The code uses the dictionary to hold all the sheet names.
' Only if the specified sheet exists, it will be removed from
' the dictionary and the remaining sheets in it will be deleted
' in one go. Otherwise no action will be taken.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function deleteSheetsExceptOneByName(Book As Workbook, _
ByVal SheetName As String) _
As Long
' Initialize error handling.
Const ProcName As String = "deleteSheetsExceptOneByName"
On Error GoTo clearError ' Turn on error trapping.
' Validate workbook.
If Book Is Nothing Then
GoTo NoWorkbook
End If
' Define dictionary.
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
' Write sheet names to dictionary.
Dim sh As Object
For Each sh In Book.Sheets
.Add sh.Name, Empty
Next sh
' Validate sheet name string.
If Not .Exists(SheetName) Then
GoTo NoSheet
End If
' Remove sheet name string from the dictionary.
.Remove (SheetName)
' Validate number of sheets.
If .Count = 0 Then
GoTo OneSheet
End If
' Delete sheets.
Application.DisplayAlerts = False
Book.Sheets(.Keys).Delete
Application.DisplayAlerts = True
deleteSheetsExceptOneByName = .Count
GoTo SheetsDeleted
End With
NoWorkbook:
Debug.Print "'" & ProcName & "': No workbook ('Nothing')."
GoTo ProcExit
NoSheet:
Debug.Print "'" & ProcName & "': No sheet named '" & SheetName _
& "' in workbook."
GoTo ProcExit
OneSheet:
Debug.Print "'" & ProcName & "': Sheet '" & Book.Sheets(SheetName).Name _
& "' is the only sheet in workbook."
GoTo ProcExit
SheetsDeleted:
If deleteSheetsExceptOneByName > 1 Then
Debug.Print "'" & ProcName & "': Deleted " _
& deleteSheetsExceptOneByName & " sheets in workbook."
Else
Debug.Print "'" & ProcName & "': Deleted 1 sheet in workbook."
End If
GoTo ProcExit
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
ProcExit:
End Function
You're missing the first part of the requisite For Each loop.
Also best to use a Workbook variable to refer to each workbook being opened and modified:
Do While Myfile <> ""
Dim MyWB As Workbook
Set MyWB = Workbooks.Open(MyFile)
For Each ws in MyWB.Worksheets
If ws.Name <> "name of sheet to keep" Then
ws.Delete
End If
Next
myWB.Close True
MyFile = Dir
Loop
Just for the sake of completeness I added the code and checked if the sheet to be kept exists so in case it doesn't, there isn't an error raised.
Read the code's comments.
Public Sub DeleteSheetsExceptInFiles()
Dim targetFile As String
Dim targetDirectory As String
Dim keepSheetName As String
Dim str As String
' Basic error handling
On Error GoTo CleanFail
' Define directory, file and sheet name
targetDirectory = "C:\Temp\"
targetFile = Dir(targetDirectory & "*.xlsx")
keepSheetName = "name of sheet to keep"
' Speed up process
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Loop through files
Do While targetFile <> ""
Dim targetWorkbook As Workbook
Set targetWorkbook = Workbooks.Open(targetDirectory & targetFile)
' Check if sheet to keep exists
Dim targetSheet As Worksheet
Dim keepSheetExists As Boolean
On Error Resume Next
keepSheetExists = targetWorkbook.Worksheets(keepSheetName)
On Error GoTo CleanFail
' Proceed if sheet exists
If keepSheetExists = True Then
For Each targetSheet In targetWorkbook.Worksheets
' Delete all sheets except the one to keep
If targetSheet.Name <> keepSheetName Then
targetSheet.Delete
End If
Next targetSheet
End If
targetWorkbook.Close True
targetFile = Dir()
Loop
CleanExit:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
CleanFail:
Debug.Print "Something went wrong: " & Err.Description
Resume CleanExit
End Sub
I run VBA code in Access and update an existing Excel file.
I have to create xls files for each sales person and update the cells by grouping customer of monthly sales point by exporting data from an Access accdb file which is connected to Oracle database by ODBC driver.
We have about 50 sales persons and will have to create 2 files on each. If I can not fix the problem I will have 100 Excel processes on my PC. It might be frozen when run even if I successfully run the accdb with VBA.
Problems:
Can not close Excel process by Application.Quit which I tried to
open a xls file by Excel.Application.Workbooks object and it seems
be it's caught the xls file still even I used .Close
SaveChanges:=True
Can not process the VBA code again against same file cause of the
previous excel file operation process is left which I confirmed it
on task manager that I have to kill the process manually every time.
I googled on the internet and MSDN site. I could not find any good solution.
Option Compare Database
Const TARGET_SHEET = "SalesObjectiveSheet"
Const FILE_CREATION_WORK_FOLDER As String = "Work"
Const DESTINATION_ROOTPATH As String = "C:\Users\Administrator\Desktop"
Const TARGET_SHEET2 As String = "SalesObjectivesSheet"
Const HEADING_LINE_POSITION As Integer = 3
Public objApp As Excel.Application
Public objBooks As Excel.Workbooks
Public objBook As Excel.Workbook
Public objSheets As Excel.Worksheets
Public objSheet As Excel.Worksheet
Public Sub test200()
Dim str As Boolean
On Error GoTo Err_Handler
strSalesName = "SalesName"
strSalesOffice = "Tokyo"
strTargetFolder = DESTINATION_ROOTPATH & "\" & FILE_CREATION_WORK_FOLDER
strTargetFileName = "SalesObjectiveSheet_201708.xlsx"
strTargetFullPath = strTargetFolder & "\" & strTargetFileName
Set objApp = CreateObject("Excel.Application")
Set objBook = objApp.Workbooks.Open(strTargetFullPath)
Set objSheet = objBook.Worksheets(TARGET_SHEET2)
If EditObjectSheetHeader(objSheet, objApp, objBook, _
objBooks, strSalesName, strSalesOffice, strTargetFileName) = False Then
GoTo Err_Handler
End If
Exit_Handler:
objApp.Quit
Set objSheet = Nothing
Set objBooks = Nothing
Set objApp = Nothing
Exit Sub
Err_Handler:
' SysCmd acSysCmdRemoveMeter
Resume Exit_Handler
End Sub
Function EditObjectSheetHeader(objSheet As Object, objApp As Object, objBook As Object, _
objBooks As Object, strSalesName, strSalesOffice, strTargetFileName) As Boolean
Dim strProcedureName As String
Dim strMonth As String
On Error GoTo Err_Handler
objSheet.Select
objSheet.Activate
strProcedureName = "EditObjectSheetHeader"
EditObjectSheetHeader = False
With objSheet.PageSetup
.CenterHeader = "&14 " & "Month Sales Objectives"
.RightHeader = "" & Chr(10) & "Sales Office：" & strSalesOffice & " Name：" & strSalesName
.CenterFooter = "&P/&N"
.PrintTitleRows = "$1:$" & HEADING_LINE_POSITION
.LeftHeader = ""
End With
Exit_Handler:
Workbooks(strTargetFileName).Close SaveChanges:=True
' Frozen after I run the VBA code once cause of previous & _
process use same file is existed it seems be.
' ActiveWorkbook.Close saveChanges:=True
' Frozen after I run the VBA code once cause of & _
previous process use same file is existed & _
(Object and With is not defined error)
' objBook.Close SaveChanges:=True
' Frozen after I run the VBA code once cause of & _
previous process use same file is existed & _
it seems be.
' ActiveWorkbook.Close SaveChanges:=True
' Error unknown.
' ThisWorkbook.Save
'Error 1004 unknown.
EditObjectSheetHeader = True
Exit Function
Err_Handler:
Select Case Err.Number
Case 9
Debug.Print strProcedureName, Err.Number, Err.Description
MsgBox Err.Description & " " & Err.Number, vbOKOnly, strProcedureName
Case 70
Debug.Print strProcedureName, Err.Number, Err.Description
MsgBox Err.Description & " " & Err.Number, vbOKOnly, strProcedureName
Resume
Case Else
Debug.Print strProcedureName, Err.Number, Err.Description
MsgBox Err.Description & " " & Err.Number, vbExclamation, strProcedureName
End Select
End Function
Below line helped, but any other opened xls also will be closed:
Shell "taskkill /F /IM EXCEL.EXE /T"
Try placing objApp.Quit after releasing references.
Set objSheet = Nothing
Set objBooks = Nothing
Set objApp = Nothing
If Not objApp is Nothing Then objApp.Quit
Being an absolute VBA novice, I've pieced together some code that will run through an Excel sheet, checking everything's there, and then saving the sheet as a PDF file. I am, however, having some trouble with the saving part of the code. I keep getting the error "Compile error: Expected:=" to this line:
`Wsa.ExportAsFixedFormat(Type:=xlTypePDF,Filename:=myFile,Quality:=xlQualityStandard,IncludeDocProperties:=True,IgnorePrintAreas:=False, OpenAfterPublish:=False)´
Am I just being a complete n00b here?
The whole thing looks like this:
Sub mcrSave()
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler
'Check for mandatory fields
If Range("B3").Value = "" Then MsgBox ("Please fill in applicant")
Exit Sub
If Range("C1").Value = "" Then MsgBox ("Please fill in project title")
Exit Sub
If Range("H3").Value = "" Then MsgBox ("Please fill in date of application")
Exit Sub
If Range("C5").Value = "" Then MsgBox ("Please fill in expected cost")
Exit Sub
If Range("C7").Value = "" Then MsgBox ("Please fill in time schedule")
Exit Sub
If Range("B10").Value = "" Then MsgBox ("Please fill in project description")
Exit Sub
If Range("B18").Value = "" Then MsgBox ("Please fill in potential benefits")
Exit Sub
If Range("B26").Value = "" Then MsgBox ("Please fill in potential drawbacks")
Exit Sub
If Range("B34").Value = "" Then MsgBox ("Please fill in internal/external ressources")
Exit Sub
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")
'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile
'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename(InitialFileName:=strPathFile, FileFilter:="PDF Files (*.pdf), *.pdf", Title:="Select Folder and FileName to save")
'export to PDF if a folder was selected
If myFile <> "False" Then
Wsa.ExportAsFixedFormat(Type:=xlTypePDF,Filename:=myFile,Quality:=xlQualityStandard,IncludeDocProperties:=True,IgnorePrintAreas:=False, OpenAfterPublish:=False)
'confirmation message with file info
MsgBox "PDF file has been created: " & vbCrLf & myFile
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
Syntax error. The correct syntax is either
call Wsa.ExportAsFixedFormat(Type:=xlTypePDF,Filename:=myFile,...)
or
Wsa.ExportAsFixedFormat Type:=xlTypePDF,Filename:=myFile,...
Change your Export command to the following:
Wsa.ExportAsFixedFormat Type:=xlTypePDF, Filename:=myFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Also, you need to change your Mandatory field checks so each looks like:
If Range("B3").Value = "" Then
MsgBox ("Please fill in applicant")
Exit Sub
End If