I keep getting a 'Method 'SaveAS' of object '_Workbook' failed, I can't for the life of me figure out why. Code below... any recommendation unrelated to the initial question are welcome!
Private Sub CommandButton1_Click()
'Declarations
'The two workbooks to be involved
Dim SourceWB As Workbook
Dim DestinationWB As Workbook
'values to contain cell data to be copied across the worksheet
Dim systemName As Variant
Dim systemID As Variant
'Counter variable to allow for the loop
Dim counter As Integer
'Set the source workbook equal to the current workbook
Set SourceWB = ActiveWorkbook
For counter = 1 To 5
'Set the values for the two data values to be copied
systemName = SourceWB.Sheets("Sheet1").Cells(counter, 1).Value
systemID = SourceWB.Sheets("Sheet1").Cells(counter, 2).Value
'Open the destination Workbook
Set DestinationWB = Workbooks.Open("Path to workbook")
'Set destination cells equal to the copied data from the source sheet
DestinationWB.Sheets("Questionnaire").Cells(7, 3).Value = systemName
DestinationWB.Sheets("Questionnaire").Cells(8, 3).Value = systemID
'Set fname to save Destination Workbook
Fname = "H:\Desktop\Automated Questionnaires to send\" & systemName & " Applicability Questionnaire.xlsm"
'Save the Destination workbook
DestinationWB.SaveAs Filename:=Fname, FileFormat:=52
DestinationWB.Close
Next counter
End Sub
Related
I have macro that finds the value "a" and replaces with value "b" across multiple worksheets and workbooks
the macro loops through files in folder and files in subfolders and replaces all the values it can find.
now i want the macro to return the file name in column E of the worksheet the macro is written in, ONLY IF changes where made in the file ( so if a was replaced with b return file name in colum E)
but my current code it only returns the file name of the first workbook it runs through.
my codes starts at sub search and it takes as an input sub()
Sub FindReplaceAcrossMultipleExcelWorkbooksFreeMacro(Path As String)
Dim CurrentWorkbookName As String
Dim ExcelCounter As Integer
Dim ExcelWorkbook As Object
Dim FindReplaceCounter As Integer
Dim FindandReplaceWorkbookName As String
Dim FindandReplaceWorksheetName As String
Dim LastRow As Integer
Dim oFile As Object
Dim oFolder As Object
Dim oFSO As Object
Dim Shape As Shape
Dim ws As Worksheet
Dim myrange As Range
Dim look As String
FindandReplaceWorkbookName = ActiveWorkbook.Name
FindandReplaceWorksheetName = ActiveSheet.Name
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(Path)
For Each oFile In oFolder.Files 'Loop through every File in Active Workbook's folder path
If InStr(1, oFile.Type, "Microsoft Excel") <> 0 And InStr(1, oFile.Name, FindandReplaceWorkbookName) = 0 And InStr(1, oFile.Name, "~") = 0 Then 'If the File Type contains the phrase Microsoft Excel isn't the current Excel Workbook and is NOT Lock File
Set ExcelWorkbook = Application.Workbooks.Open(Path & "\" & oFile.Name) 'Open Excel Workbook
CurrentWorkbookName = ActiveWorkbook.Name 'Name of Active Excel Workbook that was opened
Application.Workbooks(CurrentWorkbookName).Activate 'Ensure open Excel Workbook is active for future reference using ActiveWorkbook
Application.ScreenUpdating = False 'Limit screen flashing when Excel Workbooks opened and when Find & Replace is completed
FindReplaceCounter = 2
LastRow = Workbooks(FindandReplaceWorkbookName).Sheets(FindandReplaceWorksheetName).Cells(Rows.Count, 1).End(xlUp).Row 'Identify Last Row in Column A
Do Until FindReplaceCounter > LastRow 'Complete the Find and Replace for all values in Column A & B
For Each ws In ActiveWorkbook.Worksheets 'Loop through every Excel Worksheet in Active Excel Workbook
Set myrange = ws.UsedRange.Find(what:="ben")
If Not myrange Is Nothing Then
Workbooks(FindandReplaceWorkbookName).Sheets(FindandReplaceWorksheetName).Range("E" & Rows.Count).End(xlUp).Offset(1, 0) = ExcelWorkbook.Name
End If
ws.Cells.Replace what:=Workbooks(FindandReplaceWorkbookName).Sheets(FindandReplaceWorksheetName).Cells(FindReplaceCounter, 1).Value, Replacement:=Workbooks(FindandReplaceWorkbookName).Sheets(FindandReplaceWorksheetName).Cells(FindReplaceCounter, 2).Value
Next ws
FindReplaceCounter = FindReplaceCounter + 1
Loop
ActiveWorkbook.Save 'Save Active Excel Workbook
ActiveWorkbook.Close 'Close Active Excel Workbook
End If
Next oFile
Application.ScreenUpdating = True 'Turn Excel ScreenUpdating back on
Set ExcelWorkbook = Nothing
Set oFSO = Nothing
Set oFolder = Nothing
Set oFile = Nothing
Exit Sub
End Sub
Sub Search()
FindReplaceAcrossMultipleExcelWorkbooksFreeMacro (Cells(2, 3).Value)
MsgBox "The Find and Replace has been completed."
End Sub
If I understand you correctly, maybe the code below can help you to compare it with your case.
Sub test()
Dim rg As Range: Dim wb As Workbook
Dim oFSO: Dim oFolder: Dim oFile
Dim fn As String: Dim sh As Worksheet: Dim cell As Range
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
With wb.Sheets("Sheet1")
Set rg = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
.Range("E:E").ClearContents
End With
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder("D:\test")
For Each oFile In oFolder.Files
fn = oFile.Name
If InStr(fn, "test") Then GoTo nextfile:
Workbooks.Open oFile
With ActiveWorkbook
For Each sh In .Worksheets
For Each cell In rg
If Not sh.Cells.Find(cell.Value) Is Nothing Then
sh.UsedRange.Replace what:=cell.Value, Replacement:=cell.Offset(0, 1).Value, LookAt:=xlWhole
wb.Sheets("Sheet1").Range("E" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
fn & " - " & sh.Name & " : value " & cell.Value & " is replaced with " & cell.Offset(0, 1).Value
End If
Next
Next
.Close SaveChanges:=False
End With
nextfile:
Next oFile
Application.ScreenUpdating = True
End Sub
To test the code, create 3 workbooks :
Name the first wb "test.xlsm", this is the wb where the code resides. In test.xlsm sheet Sheet1, make two column header in column A and B, and name it : FIND in A1 and REPLACE in B1. Under FIND, put data such as aaa in A2, bbb in A3, ccc in A4. Under REPLACE, put data such as XXX in B2, YYY in B3, ZZZ in B4.
Create other two workbooks, name it as you like. In each wb, put aaa and/or bbb and/or ccc to whatever cell whatever sheet as many as you like.
put test.xlsm and the other two workbooks in one folder in drive D:, name the folder "test".
Run the code in test.xlsm. Make sure that the other two workbooks is close.
There are three loops in the code.
The first is to loop to each file in test folder
The second is to loop to each sheet of that file
The third is to loop to each FIND/REPLACE value in sheet Sheet1 test.xlsm
On the first loop, it open the file / workbook (which is not test.xlsm)
then it loop to each sheet of that opened wb
on looped sheet, it loop to each data under FIND/REPLACE in sheet1 test.xlsm, and check if the looped cell value is found in the looped sheet, then it perform two process : (A) the found value is replaced with replace value (B) write the information in column E sheet1 of test.xlsm
Please note, the code doesn't write information on the looped sheet of the looped workbook which is being opened. It's just replace to a new value if the value to be replaced is found.
If you run the sub for the second time, there shouldn't be any information in column E sheet Sheet1 in test.xlsm.
I've got over 200 workbooks that I need to merge, the code below will merge the workbooks and add all the sheets into one workbook.
In that workbook the sheets are being named Sheet 1 (1), Sheet 1 (2) and so on.
If the sheet was copied from Workbook1 the sheet name would be workbook 1
Sub mergeFiles()
'Merges all files in a folder to a main file.
'Define variables:
Dim numberOfFilesChosen, i As Integer
Dim tempFileDialog As FileDialog
Dim mainWorkbook, sourceWorkbook As Workbook
Dim tempWorkSheet As Worksheet
Set mainWorkbook = Application.ActiveWorkbook
Set tempFileDialog = Application.FileDialog(msoFileDialogFilePicker)
'Allow the user to select multiple workbooks
tempFileDialog.AllowMultiSelect = True
numberOfFilesChosen = tempFileDialog.Show
'Loop through all selected workbooks
For i = 1 To tempFileDialog.SelectedItems.Count
'Open each workbook
Workbooks.Open tempFileDialog.SelectedItems(i)
Set sourceWorkbook = ActiveWorkbook
'Copy each worksheet to the end of the main workbook
For Each tempWorkSheet In sourceWorkbook.Worksheets
tempWorkSheet.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
Next tempWorkSheet
'Close the source workbook
sourceWorkbook.Close
Next i
End Sub
Add this in you For Each loop
Dim j as integer ‘Add to top of your sub
j = 0 ‘Add inside for loop
For Each tempWorkSheet In sourceWorkbook.Worksheets
j= j+1
tempWorkSheet.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
ActiveSheet.Name = sourceWorkBook.Name & “ - “ & j ‘Added Line of code to rename copied tab
Next tempWorkSheet
As long as your workbook names aren’t too long or duplicate, it should be good
Merge Files
Code Issues
You have declared numberOfFilesChosen as Variant:
Dim numberOfFilesChosen, i As Integer ' Wrong
Dim numberOfFilesChosen as Integer, i As Integer ' OK
You have declared mainWorkbook as Variant:
Dim mainWorkbook, sourceWorkbook As Workbook ' Wrong
Dim mainWorkbook as Workbook, sourceWorkbook As Workbook ' OK
Such a code should be in the Workbook (mainWorkbook) where the
Worksheets are being imported, so you don't need a variable, just use
ThisWorkbook. Then in combination with the With statement, you
can use e.g. .Sheets(.Sheets.Count).
You are changing between sheets and worksheets. When you use mainWorkbook.Worksheets.Count, this might not necessarily be the last sheet, so it would be more correct to use mainWorkbook.Sheets.Count especially for the added sheet counter to function correctly.
tempWorkSheet.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
tempWorkSheet.Copy after:=mainWorkbook.Sheets(mainWorkbook.Sheets.Count) ' Preferable
When you use sourceWorkbook.Close, you might be asked to save the workbook. Using
sourceWorkbook.Close False ' Preferable
will close the workbook without saving changes.
The code will fail if you run it another time, because the sheet names
it will try to create are the same. Therefore I have added
DeleteWorksheetsExceptOne which I used while testing the code.
The Code
Sub mergeFiles()
'Merges all files in a folder to a main file.
'Define variables:
Dim tempFileDialog As FileDialog
Dim sourceWorkbook As Workbook
Dim tempWorkSheet As Worksheet
Dim numberOfFilesChosen As Long, i As Long, j As Long
Set tempFileDialog = Application.FileDialog(msoFileDialogFilePicker)
'Allow the user to select multiple workbooks
tempFileDialog.AllowMultiSelect = True
numberOfFilesChosen = tempFileDialog.Show
With ThisWorkbook
'Loop through all selected workbooks
For i = 1 To tempFileDialog.SelectedItems.Count
'Open each workbook
Workbooks.Open tempFileDialog.SelectedItems(i)
Set sourceWorkbook = ActiveWorkbook
j = 0
'Copy each worksheet to the end of the main workbook
For Each tempWorkSheet In sourceWorkbook.Worksheets
j = j + 1
tempWorkSheet.Copy After:=.Sheets(.Sheets.Count)
' Rename newly added worksheet to the name of Source Workbook
' concatenated with "-" and Counter (j).
.Sheets(.Sheets.Count).Name = sourceWorkbook.Name & "-" & j
Next
'Close the source workbook. False for not saving changes.
sourceWorkbook.Close False
Next
End With
End Sub
Delete All Worksheets But One
'*******************************************************************************
' Purpose: Deletes all Worksheets in the ActiveWorkbook except one.
' Danger: This code doesn't ask anything, it just does. In the end you will
' end up with just one worksheet (cStrWsExcept) in the workbook
' (cStrWbPath). If you have executed this code and the result is not
' satisfactory, just close the workbook and try again or don't. There
' will be no alert like "Do you want to save ..." because of the line:
' ".Saved = True" i.e. "objWb.Saved = True".
' Arguments (As Constants):
' cStrWbPath
' The path of the workbook to be processed. If "", then ActiveWorkbook is
' used.
' cStrWsExcept
' The worksheet not to be deleted. If "", then the Activesheet is used.
'*******************************************************************************
Sub DeleteWorksheetsExceptOne()
Const cStrWbPath = "" ' if "" then ActiveWorkbook
Const cStrWsExcept = "Sheet1" ' if "" then ActiveSheet
Dim objWb As Workbook
Dim objWsExcept As Worksheet
Dim objWsDelete As Worksheet
If cStrWbPath = "" Then
Set objWb = ActiveWorkbook
Else
Set objWb = Workbooks(cStrWbPath)
End If
With objWb
If cStrWsExcept = "" Then
Set objWsExcept = .ActiveSheet
Else
Set objWsExcept = .Worksheets(cStrWsExcept)
End If
' To suppress the "Data may exist in the sheet(s) selected for deletion.
' To permanently delete the data, press Delete." - Alert:
Application.DisplayAlerts = False
For Each objWsDelete In .Worksheets
If objWsDelete.Name <> objWsExcept.Name Then
objWsDelete.Delete
End If
Next
' To suppress the "Do you want to save changes you made to ... ?" - Alert:
.Saved = True
Application.DisplayAlerts = True
End With
End Sub
'*******************************************************************************
I have a workbook that gets created every week that has a variable name structure. The name structure is as follows : Week of Year & Invoice & date. So a sample file might be called 1_Invoice_01052018.xlsm
I have to update the report every week. I want to declare the variable workbook name as a variable in VBA. I have another workbook that contains the output of the report that is created via VBA. In this other workbook I want to be able to call the Invoice spreadsheet but since it has a variable name, I am having issues finding it. So I put together the VBA below.
Sub Test()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = "*Invoice*" & ".xlsm"
Set ws = Sheets("Sheet1")
wb.Activate
ws.Select
End Sub
However, this results in a "Type mismatch" error.
I also tried the following:
Sub Test2()
Windows("*Invoice*" & ".xlsm").Activate
End Sub
This also resulted in an error.
Any ideas on how to set a variable workbook name as a variable in VBA? I would only have one of these workbooks open at a time, so I wouldn't run into any issues
You have to set the workbook correctly:
Sub Test()
Dim wb As Workbook
Dim ws As Worksheet
Dim FilePath As String
FilePath = "C:\" & AnotherVariable & ".xlsx"
Set wb = Workbooks(FilePath)
Set ws = Sheets("Sheet1")
wb.Activate
ws.Select
End Sub
To create a new workbook you'd use Workbooks.Add. To open an existing one you'd use Workbooks.Open and then reference the worksheet within that workbook.
To change the name of the file you'd save it with a new name using the SaveAs method.
Sub Test()
Dim wb As Workbook
Dim ws As Worksheet
Dim FileName As String
Set wb = Workbooks.Add 'Creates a new workbook with default name.
'Set wb = Workbooks.Open("<path to folder>\" & FileName & ".xlsm") 'Open an existing file.
Set ws = wb.Worksheets("Sheet1")
wb.SaveAs "<path to folder>\" & FileName & ".xlsm" 'Save and rename here.
With ws
.Range("A1") = "Adding some text to this cell"
End With
End Sub
As a further example, the code below will create two workbooks before copying the sheet from the first workbook to the end of the second workbook.
Sub Test1()
Dim wb As Workbook, wb1 As Workbook
Dim ws As Worksheet
'Create first workbook so it contains only 1 sheet (xlWBATWorksheet)
', reference Sheet1 and add some data to it.
Set wb = Workbooks.Add(xlWBATWorksheet)
Set ws = wb.Worksheets("Sheet1")
ws.Range("A1") = "This cell populated in first workbook."
'Create second workbook with default number of sheets
'and copy Sheet1 from first book to the end of this one.
Set wb1 = Workbooks.Add
ws.Copy After:=wb1.Sheets(wb1.Sheets.Count)
End Sub
Edit again:
To figure out the workbook name based on WeekNumber_Invoice_Date you could use:
Sub Test2()
Dim wb As Workbook
Dim sPath As String
Dim dDate As Date
dDate = Date 'Todays date
sPath = "C:\MyFolder\"
sPath = sPath & _
WorksheetFunction.WeekNum(dDate, 2) & "_Invoice_" & Format(dDate, "ddmmyyyy") & ".xlsm"
'Open if already exists.
'Set wb = Workbooks.Open(sPath)
'Create and SaveAs new name.
Set wb = Workbooks.Add
wb.SaveAs sPath
End Sub
This would give a file path of C:\MyFolder\43_Invoice_22102018.xlsm based on todays date of 22nd October '18.
Note: The WEEKNUM function considers the week containing January 1 to be the first week of the year.
I was able to get what I need from the following link:
excel-vba-extract-text-between-2-characters
I reviewed the link above and put together the VBA below.
Sub test2()
Dim str As String
Dim openPos As Integer
Dim closePos As Integer
Dim midBit As String
str = Range("b1").Value
openPos = InStr(str, "[")
closePos = InStr(str, "]")
midBit = Mid(str, openPos + 1, closePos - openPos - 1)
'MsgBox (midBit)
Windows(midBit).Activate
End Sub
I ended up creating a dynamic file path in cell B1 that contained a concatenated file path string that contained look ups to pull in the Week of Year and Date based on the Current Date. Since this path is dynamic it will always point to the right path given that I open the Invoice on the correct week. I pulling the file name from the path and opening based on the file name which is dynamic.
When using all the different examples that I've found on stackoverflow they give me a complex task that still requires a mouse click to confirm its ok to paste the data. I also am struggling to get the whole thing to operate in one section of VBA code.
Public Sub copySheets()
Dim wkb As Excel.Workbook
Dim newWkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim newWks As Excel.Worksheet
Dim sheets As Variant
Dim varName As Variant
'------------------------------------------------------------
'Define the names of worksheets to be copied.
sheets = VBA.Array("Analysis - London", "London - Commercial")
'Create reference to the current Excel workbook and to the destination workbook.
Set wkb = Excel.ThisWorkbook
Set newWkb = Excel.Workbooks.Add
For Each varName In sheets
'Clear reference to the [wks] variable.
Set wks = Nothing
'Check if there is a worksheet with such name.
On Error Resume Next
Set wks = wkb.Worksheets(VBA.CStr(varName))
On Error GoTo 0
'If worksheet with such name is not found, those instructions are skipped.
If Not wks Is Nothing Then
'Copy this worksheet to a new workbook.
Call wks.Copy(newWkb.Worksheets(1))
'Get the reference to the copy of this worksheet and paste
'all its content as values.
Set newWks = newWkb.Worksheets(wks.Name)
With newWks
Call .Cells.Copy
Call .Range("A1").PasteSpecial(Paste:=xlValues)
End With
End If
Next
ActiveWorkbook.SaveCopyAs Filename:=("C:\Users\\My stuff\Forecast" & Format(Now(), "YYYYMMDD") & " Forecasting" & ".xlsm")
Thanks
Replace
With newWks
Call .Cells.Copy
Call .Range("A1").PasteSpecial(Paste:=xlValues)
End With
With
Dim c as range
For each c in newwks.usedrange
c.formula = c.value
next c
I have 3 workbooks
source workbook
target workbook
reference workbook - (Containing the macro which visible across all workbooks)
Is it possible to change switch between Active workbook ( target workbook) and ( source workbook which was active workbook).
Activate doesn't seem to help me, I do not if this is a bug or what it is. I have stopped in this step for quite sometime now.
This workbook function takes me back to reference workbook.
Hope my question is clear. Appreciate your help.
' My code is in a test macroworkbook
' I am having a workbook opened 1.xlsx
' Opening a workbook countrypricelist.xls
'running the code from
Dim sourcewb As Workbook
Dim targetWorkbook As Workbook
Dim filter As String
Dim filter2 As String
Dim rw As Long
Dim x As Range
Dim y As Range
Set sourcewb = ActiveWorkbook
Set x = sourcewb.Worksheets(1).Range("A:F")
Dim sourceSheet As Worksheet
Set sourceSheet = sourcewb.Worksheets(1)
MsgBox sourceSheet.Name
x.Select
MsgBox sourceSheet.Name
x.Select
MsgBox sourcewb.Name ' This gives me sourceworkbook name.
filter = "(*.xls),*.xls"
Caption = "Please Select an input file "
Application.ScreenUpdating = False
Filename = Application.GetOpenFilename(filter, , Caption)
Set targetWorkbook = Application.Workbooks.Open(Filename)
Set y = targetWorkbook.Worksheets(1).Range("A:F")
y.Select
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets(1)
MsgBox targetSheet.Name
Set targetWorkbook = ActiveWorkbook
MsgBox targetWorkbook.Name 'This gives me target workbook name
y.Select
sourcewb.Activate
MsgBox sourcewb.Name ' Source workbook becomes same as targeworkbook.
x.Select
MsgBox sourcewb.Name & " This is the source workbook "
MsgBox targetWorkbook.Name & " This is the target workbook "
With sourcewb.Worksheets(1)
For rw = 2 To Cells(Rows.Count, 1).End(xlUp).Row
Cells(rw, 3) = Application.VLookup(Cells(rw, 2).Value2, x, 3, False)
Cells(rw, 4) = Application.VLookup(Cells(rw, 2).Value2, x, 4, False)
Cells(rw, 5) = Application.VLookup(Cells(rw, 2).Value2, x, 5, False)
Next rw
End With
MsgBox "All required columns from source mapped to target file "
MsgBox "Trying to map from target to source "
Set sourcewb = ActiveWorkbook
MsgBox ActiveWorkbook.Name
Application.ScreenUpdating = False
So If I change the line sourcewb = Thisworkbook my reference is changed to source code to workbook which is not my desired workbook as it contains many other macros for other activities. Hope this is code is fine.
The Excel Workbook Object allows you to programatically open, edit and close any workbook, not just the currently 'Activated' one.
Example:
Dim wb as Excel.Workbook, otherwb as Excel.Workbook
Dim ws as Excel.Worksheet, otherws as Excel.Worksheet
Set wb = Workbooks.Open "somefile.xlsx"
Set otherwb = Workbooks.Open "otherfile.xlsx"
Set ws = wb.Sheets(1)
Set otherws = otherwb.Sheets(1)
' do stuff
ws.Cells(1,1) = otherws.Cells(1,1)
'save changes
wb.Save