Save copy of workbook as new xlsm, runtime error 1004 - vba

I'm trying to save a copy of the workbook as a new .xlsm file via the following code:
SaveAs FileName:=StrPadHoofdDocument & "\Docs\" & "\n\" & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
I get the following error: "runtime error 1004: method of object SaveAs of object_Workbook failed"
I've read a lot of other topics with the same kind of problem but I just can't quite solve it. Hope you guys can help!
full code:
Sub motivatieFormOpmaken()
Const StBestand = "Stambestand.xlsm"
Const motivatie = "Template motivatieformulier opstapregeling.xlsx"
Dim wbMotivTemp As Workbook
Dim wsMotiv As Worksheet
Dim PathOnly, mot, FileOnly As String
Dim StrPadSourcenaam As String
Set wbMotivTemp = ThisWorkbook
Set wsMotiv = ActiveSheet
StrHoofdDocument = ActiveWorkbook.Name
StrPadHoofdDocument = ActiveWorkbook.Path
StrPadSourcenaam = StrPadHoofdDocument & "\" & c_SourceDump
If Not FileThere(StrPadSourcenaam) Then
MsgBox "Document " & StrPadSourcenaam & " is niet gevonden."
Exit Sub
End If
Application.ScreenUpdating = False
Workbooks.Open FileName:=StrPadSourcenaam
Application.Run "Stambestand.xlsm!unhiderowsandcolumns"
Worksheets("stambestand").Activate
iLaatsteKolom = Worksheets("stambestand").Cells.SpecialCells(xlLastCell).Column
iLaatsteRij = Worksheets("stambestand").Cells.SpecialCells(xlLastCell).row
VulKolomNr
If KolomControle = False Then Exit Sub
Aantalregels = AantalZichtbareRows
Dim rng As Range
Dim row As Range
Dim StrFileName As String
'If Aantalregels > 1 Then
Set rng = Selection.SpecialCells(xlCellTypeVisible)
For Each row In rng.Rows
iRijnummer = row.row
If iRijnummer > 1 Then
'Windows(c_SourceDump).Activate
wsMotiv.Range("motiv_cid") = Cells(iRijnummer, iKolomnrCorpID).Text
wsMotiv.Range("motiv_naam") = Cells(iRijnummer, iKolomnrNaam).Text
wsMotiv.Range("motiv_ldg") = Cells(iRijnummer, iKolomnrHuidigeLeidingGevende).Text
n = naamOpmaken
wbMotivTemp.Activate
ActiveWorkbook.SaveAs FileName:=StrPadHoofdDocument & "\Docs\" & "\n\" & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End If
Next row
End Sub
Function naamOpmaken() As String
Dim rng As Range
Dim row As Range
Set rng = Selection.SpecialCells(xlCellTypeVisible)
iRijnummer = rng.row
If iRijnummer > 1 Then
s = Cells(iRijnummer, iKolomnrNaam).Text
Dim Position As Long, Length As Long
Dim n As String
Position = InStrRev(s, " ")
Length = Len(s)
n = Right(s, Length - Position)
End If
naamOpmaken = n
End Function

Change this part:
FileName:=StrPadHoofdDocument & "\Docs\" & "\n\" & ".xlsm",
With this:
FileName:=StrPadHoofdDocument & "\Docs\" & n & ".xlsm",
As you see, the problem is that you are using twice \\. Furthermore, n is a variable and it is passed as string. In future similar cases, print the problematic string and examine it closely, with code like this:
Debug.Print StrPadHoofdDocument & "\Docs\" & "\n\" & ".xlsm"
Debug.Print StrPadHoofdDocument & "\Docs\" & n & ".xlsm"
The errors would be visible then.

Related

How to end this loop?

I currently have a VBA Code written to ask for a users input of a string as well as a certain directory, and it searches through each folder, subfolder, workbook and worksheets until it finds the string the user put in. The issue I'm running into is that after it finds the string, it continues to search the rest of the folders. The application I'll be using this in, there is only one of that string being searched. I have tried debugging, and using an if statement with "c" to match str but it keeps throwing an error. The code is attached below, any help is appreciated.
Public WS As Worksheet
Sub SearchWKBooksSubFolders(Optional Folderpath As Variant, Optional Str As Variant)
Dim myfolder As String
Dim a As Single
Dim sht As Worksheet
Dim Lrow As Single
Dim Folders() As String
Dim Folder As Variant
ReDim Folders(0)
If IsMissing(Folderpath) Then
Set WS = Sheets.Add
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
myfolder = .SelectedItems(1) & "\"
End With
Str = Application.InputBox(prompt:="Search string:", Title:="Search all workbooks in a folder", Type:=2)
If Str = "" Then Exit Sub
WS.Range("A1") = "Search string:"
WS.Range("B1") = Str
WS.Range("A2") = "Path:"
WS.Range("B2") = myfolder
WS.Range("A3") = "Folderpath"
WS.Range("B3") = "Workbook"
WS.Range("C3") = "Worksheet"
WS.Range("D3") = "Cell Address"
WS.Range("E3") = "Link"
Folderpath = myfolder
Value = Dir(myfolder, &H1F)
Else
If Right(Folderpath, 2) = "\\" Then
Exit Sub
End If
Value = Dir(Folderpath, &H1F)
End If
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If GetAttr(Folderpath & Value) = 16 Then
Folders(UBound(Folders)) = Value
ReDim Preserve Folders(UBound(Folders) + 1)
ElseIf (Right(Value, 3) = "xls" Or Right(Value, 4) = "xlsx" Or Right(Value, 4) = "xlsm") And Left(Value, 1) <> "~" Then
On Error Resume Next
Dim wb As Workbook
Set wb = Workbooks.Open(Filename:=Folderpath & Value, Password:="zzzzzzzzzzzz")
On Error GoTo 0
'If there is an error on Workbooks.Open, then wb Is Nothing:
If wb Is Nothing Then
Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
WS.Range("A" & Lrow).Value = Value
WS.Range("B" & Lrow).Value = "Password protected"
Else
For Each sht In wb.Worksheets
'Expand all groups in sheet
sht.Unprotect
sht.Outline.ShowLevels RowLevels:=8, ColumnLevels:=8
Set c = sht.Cells.Find(Str, After:=sht.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
WS.Range("A" & Lrow).Value = Folderpath
WS.Range("B" & Lrow).Value = Value
WS.Range("C" & Lrow).Value = sht.Name
WS.Range("D" & Lrow).Value = c.Address
WS.Hyperlinks.Add Anchor:=WS.Range("E" & Lrow), Address:=Folderpath & Value, SubAddress:= _
"'" & sht.Name & "'" & "!" & c.Address, TextToDisplay:="Link"
Set c = sht.Cells.FindNext(After:=c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Next sht
wb.Close False
End If
End If
End If
Value = Dir
Loop
For Each Folder In Folders
Call SearchWKBooksSubFolders(Folderpath & Folder & "\", Str)
Next Folder
Cells.EntireColumn.AutoFit
End Sub
Add a boolean variable that you set to True to indicate that you've found what you're looking for. Something like this:
Sub SearchWKBooksSubFolders(Optional Folderpath As Variant, Optional Str As Variant)
Dim myfolder As String
Dim a As Single
Dim sht As Worksheet
Dim Lrow As Single
Dim Folders() As String
Dim Folder As Variant
ReDim Folders(0)
If IsMissing(Folderpath) Then
Set WS = Sheets.Add
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
myfolder = .SelectedItems(1) & "\"
End With
Str = Application.InputBox(prompt:="Search string:", Title:="Search all workbooks in a folder", Type:=2)
If Str = "" Then Exit Sub
WS.Range("A1") = "Search string:"
WS.Range("B1") = Str
WS.Range("A2") = "Path:"
WS.Range("B2") = myfolder
WS.Range("A3") = "Folderpath"
WS.Range("B3") = "Workbook"
WS.Range("C3") = "Worksheet"
WS.Range("D3") = "Cell Address"
WS.Range("E3") = "Link"
Folderpath = myfolder
value = Dir(myfolder, &H1F)
Else
If Right(Folderpath, 2) = "\\" Then
Exit Sub
End If
value = Dir(Folderpath, &H1F)
End If
'---Add this:
Dim TimeToStop As Boolean
'---Change this:
Do Until TimeToStop
If value = "." Or value = ".." Then
Else
If GetAttr(Folderpath & value) = 16 Then
Folders(UBound(Folders)) = value
ReDim Preserve Folders(UBound(Folders) + 1)
ElseIf (Right(value, 3) = "xls" Or Right(value, 4) = "xlsx" Or Right(value, 4) = "xlsm") And Left(value, 1) <> "~" Then
On Error Resume Next
Dim wb As Workbook
Set wb = Workbooks.Open(fileName:=Folderpath & value, Password:="zzzzzzzzzzzz")
On Error GoTo 0
'If there is an error on Workbooks.Open, then wb Is Nothing:
If wb Is Nothing Then
Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
WS.Range("A" & Lrow).value = value
WS.Range("B" & Lrow).value = "Password protected"
Else
For Each sht In wb.Worksheets
'Expand all groups in sheet
sht.Unprotect
sht.Outline.ShowLevels RowLevels:=8, ColumnLevels:=8
Set c = sht.Cells.Find(Str, After:=sht.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not c Is Nothing Then
'---Add this
TimeToStop = True 'since we found what we're looking for
firstAddress = c.Address
Do
Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
WS.Range("A" & Lrow).value = Folderpath
WS.Range("B" & Lrow).value = value
WS.Range("C" & Lrow).value = sht.Name
WS.Range("D" & Lrow).value = c.Address
WS.Hyperlinks.Add Anchor:=WS.Range("E" & Lrow), Address:=Folderpath & value, SubAddress:= _
"'" & sht.Name & "'" & "!" & c.Address, TextToDisplay:="Link"
Set c = sht.Cells.FindNext(After:=c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Next sht
wb.Close False
End If
End If
End If
value = Dir
'---Add these 3 lines
If Len(value) = 0 Then
TimeToStop = True
End If
Loop
For Each Folder In Folders
Call SearchWKBooksSubFolders(Folderpath & Folder & "\", Str)
Next Folder
Cells.EntireColumn.AutoFit
End Sub
Do note that you're calling your routine recursively:
For Each Folder In Folders
Call SearchWKBooksSubFolders(Folderpath & Folder & "\", Str)
Next Folder
Once you've gone through all your searching routine, you're going to start all over again because you're calling your Sub from within your Sub. Don't know if this is what you're after, and it may be an additional cause of further unexpected looping.
"If Str = c.Value Then GoTo 85"
Change to
"If Str = c.Value Then End"

Run-time error '1004': Method 'Range' of object '_worksheet' failed while merging

Option Explicit
Public Sub Compile_Workbook_Data()
Dim master_wkbk As Workbook: Set master_wkbk = ThisWorkbook
Dim master_sht As Worksheet: Set master_sht = ThisWorkbook.Worksheets("Task Tracking-Internal & Org.")
Dim current_wkbk As Workbook
Dim current_sht As Worksheet
Dim wkbk_list(1 To 3) As String
Dim x As Integer
Dim last_row As Integer
Dim last_col As Integer
wkbk_list(1) = "Sub Project_WorkBook - Core Services.xlsm"
wkbk_list(2) = "Sub Project_WorkBook - ESP2.0.xlsm"
wkbk_list(3) = "Sub Project_WorkBook - P2E.xlsm"
For x = 1 To UBound(wkbk_list)
Set current_wkbk = Workbooks.Open("D:\Delta Dental\" & wkbk_list(x))
Set current_sht = current_wkbk.Worksheets("Task Tracking-Internal & Org.")
last_row = current_sht.Cells.Find("*", searchorder:=xlByRows, SearchDirection:=xlPrevious).Row
last_col = current_sht.Cells.Find("*", searchorder:=xlByColumns, SearchDirection:=xlPrevious).Column
current_sht.Range(Cells(4, 1), Cells(last_row, last_col)).Copy
last_row = master_sht.Cells.Find("*", searchorder:=xlByRows, SearchDirection:=xlPrevious).Row
master_sht.Range("A" & last_row + 1).PasteSpecial Paste:=xlPasteValues
current_wkbk.Close False
Next x
End Sub
Im getting the following error while running the merge code:
Run-time error '1004': Method 'Range' of object '_worksheet' failed
The following code is your code. Yet, I made it a bit more verbose. This might allow you to tell where the error is:
Option Explicit
Public Sub Compile_Workbook_Data()
Dim master_wkbk As Workbook
Dim master_sht As Worksheet
Dim current_wkbk As Workbook
Dim current_sht As Worksheet
Dim wkbk_list(1 To 3) As String
Dim x As Integer
Dim last_row As Integer
Dim last_col As Integer
Dim bolFound As Boolean
Dim strFilePath As String
Dim strSheetName As String
Dim FSO As New FileSystemObject
Set master_wkbk = ThisWorkbook
strSheetName = "Task Tracking-Internal & Org."
strFilePath = "E:\Delta Dental\"
bolFound = False
For Each master_sht In master_wkbk.Worksheets
If master_sht.Name = strSheetName Then bolFound = True: Exit For
Next master_sht
If bolFound = False Then MsgBox "Couldn't find the required sheet in this Excel file." & Chr(10) & "Aborting...": Exit Sub
wkbk_list(1) = "Sub Project_WorkBook - Core Services.xlsm"
wkbk_list(2) = "Sub Project_WorkBook - ESP2.0.xlsm"
wkbk_list(3) = "Sub Project_WorkBook - P2E.xlsm"
If Not FSO.DriveExists(Split(strFilePath, "\")(0)) Then MsgBox "Couldn't find the required drive" & Split(strFilePath, "\")(0) & "." & Chr(10) & "Aborting...": Exit Sub
If Not FSO.FolderExists(strFilePath) Then MsgBox "Couldn't find the required folder." & Chr(10) & "Aborting...": Exit Sub
For x = 1 To UBound(wkbk_list)
If Dir(strFilePath & wkbk_list(x)) = vbNullString Then MsgBox "File " & Chr(10) & " " & strFilePath & wkbk_list(x) & Chr(10) & "not found." & Chr(10) & "Aborting...": Exit Sub
Set current_wkbk = Workbooks.Open("D:\Delta Dental\" & wkbk_list(x))
bolFound = False
For Each current_sht In current_wkbk.Worksheets
If current_sht.Name = strSheetName Then bolFound = True: Exit For
Next current_sht
If bolFound = False Then MsgBox "Couldn't find the required sheet in the file:" & Chr(10) & " " & strFilePath & wkbk_list(x) & Chr(10) & "Aborting...": Exit Sub
last_row = current_sht.Cells.Find("*", searchorder:=xlByRows, SearchDirection:=xlPrevious).Row
last_col = current_sht.Cells.Find("*", searchorder:=xlByColumns, SearchDirection:=xlPrevious).Column
current_sht.Range(Cells(4, 1), Cells(last_row, last_col)).Copy
last_row = master_sht.Cells.Find("*", searchorder:=xlByRows, SearchDirection:=xlPrevious).Row
master_sht.Range("A" & last_row + 1).PasteSpecial Paste:=xlPasteValues
current_wkbk.Close False
Next x
End Sub
Note, that the above code requires a reference to the Microsoft Scripting Runtime. Please make sure that you set it before running the code.

Re-execute if the workbook exists or not using vba Excel

I want to execute, if the workbook exists already then re- run it if not exists then create a workbook.
I have uniques values(x) and array(names). I need to compare them if both are equal if not it has to create a workbook with name of array(names) that not had in uniques values(x)
My code:
Sub mac()
Dim c as integer
Dim x as range
Dim s_AgingSCM as string
Dim Array_SCM_Aging as variant
Dim NewBook as workbook
Dim NewBook_SCM as workbook
Dim Master_workbook as workbook
Dim rngCopy_Aging as range
Dim rngFilter_Ws2 as range
For c = LBound(Array_SCM_Aging) To UBound(Array_SCM_Aging)
Set Master_workbook = ThisWorkbook
s_AgingSCM = Array_SCM_Aging(c, 1)
Set x = Master_workbook.Sheets("BASS").Range("AY" & c)
If x = s_AgingSCM Then
With rngFilter_Ws2
.AutoFilter field:=32, Criteria1:="<>(a) 0 - 360", Operator:=xlFilterValues
.AutoFilter field:=37, Criteria1:=s_AgingSCM, Operator:=xlFilterValues
Set rngCopy_Aging = .SpecialCells(xlCellTypeVisible)
.AutoFilter ' Switch off AutoFilter
End With
rngCopy_Aging.Copy NewBook.Worksheets("Aging Inventory").Cells(1, 1)
Application.DisplayAlerts = False
Else
Dim fso: Set fso = createObject("Scripting.FileSystemObject")
Dim folder: Set folder = fso.GetFolder("C:\")
Dim file, fileNames
Dim rngCopy_SCMAging As Range
For Each file In folder.Files
If Right(file.Name, 4) = "xlsx" Then
fileNames = fileNames & file.Name & ";" ' will give a list of all filenames
End If
Next
If InStr(fileNames, s_AgingSCM) = 0 Then
With NewBook_SCM
Set NewBook_SCM = Workbooks.Add
.Title = s_AgingSCM
NewBook_SCM.Worksheets("sheet1").Name = "Aging Inventory"
With rngFilter_Ws2
.AutoFilter field:=32, Criteria1:="<>(a) 0 - 360", Operator:=xlFilterValues
.AutoFilter field:=37, Criteria1:=s_AgingSCM, Operator:=xlFilterValues
Set rngCopy_SCMAging = .SpecialCells(xlCellTypeVisible)
.AutoFilter ' Switch off AutoFilter
End With
rngCopy_SCMAging.Copy Destination:=NewBook_SCM.Worksheets("Aging Inventory").Cells(1, 1)
.SaveAs Filename:="KPI" & " " & s_AgingSCM & " " & Format_date & ".xlsx"
Application.DisplayAlerts = False
NewBook_SCM.Close
End With
' Else
End If
End sub
I was stuck here since 2 days. All i want is if the workbook exists then overwrite with the new workbook or else if its not exists create a new workbook.
Can someone please help me out.
A quick way to do it would be placing: -
If fso.FileExists(Application.DefaultFilePath & "\KPI" & " " & s_AgingSCM & " " & Format_date & ".xlsx")
fso.DeleteFile Application.DefaultFilePath & "\KPI" & " " & s_AgingSCM & " " & Format_date & ".xlsx", True
End If
Above the line
.SaveAs Filename:="KPI" & " " & s_AgingSCM & " " & Format_date & ".xlsx"
But this would not account for if the file could not be deleted (i.e. already open)

Excel VBA UDF Executes in Immediate Window, Fails on Worksheet

UDF "NAV()" is designed to find the correct report on a network drive based on the first argument (always a date), then loop through all worksheets to find a piece of data with the same row as second argument and same column as third argument (second and third can be text or numbers).
Works reliably in the immediate window. Always returns #VALUE! when used on worksheet, e.g. =NAV(D7,D8,D9) or =NAV(2/19/2016,"Net Asset Value","221-I").
In general it looks like one could get this behaviour if trying to alter other cells in a UDF, but my functions don't do that. Also, I believe all range references specify which workbook and worksheet, so I don't think that is the problem either. I'm not sure where to look next.
Function also attempts to email me a report through Outlook when it fails to find what the user is looking for. I don't know if that is relevant.
Again, what is perplexing is that this code seems to work fine in the immediate window, but only gives #VALUE! when used on a worksheet.
Where else can I look in my code below to determine what would cause NAV() to function correctly in the immediate window, but always yield #VALUE! when used on a worksheet?
Option Explicit
Function NAV(ByVal NAVDate As Date, ByVal matchRow As Variant, ByVal matchColumn As Variant) As Variant
'Application.ScreenUpdating = False
Application.Volatile True
NAV = FindItemOnWorksheet(NAVDate, matchRow, matchColumn)
'Application.ScreenUpdating = True
End Function
Function FindItemOnWorksheet(ByVal NAVDate As Date, ByVal ItemSpecies As Variant, ByVal ItemGenus As Variant) As Variant
' Finds Item by opening NAV workbook with correct date, activating correct worksheet, and searching for correct row and column
Dim startingRange As Range
Dim ws As Worksheet
Dim wb As Workbook
Dim theDate As Date
Dim theItemSpecies As String
Dim theItemGenus As String
theDate = NAVDate
theItemSpecies = ItemSpecies
theItemGenus = ItemGenus
Set wb = GetWB(NAVDate)
'Loop through ws
Dim WS_Count As Integer
Dim i As Integer
WS_Count = wb.Worksheets.Count
For i = 1 To WS_Count
Set ws = wb.Worksheets(i)
Set startingRange = ws.Range("A1:Z100")
Dim theRow As Range
Dim theColumn As Range
Set theRow = startingRange.Cells.Find(theItemSpecies, SearchDirection:=xlPrevious, lookat:=xlWhole)
If Not (theRow Is Nothing) Then
Set theColumn = startingRange.Cells.Find(theItemGenus, SearchDirection:=xlPrevious, lookat:=xlWhole)
If Not (theColumn Is Nothing) Then
FindItemOnWorksheet = ws.Cells(theRow.Row, theColumn.Column).Value
wb.Close
Exit Function
End If
End If
Next i
'Loop if no hit on either row or column Find()
'following executes only if no match found
MsgBox "No Match Found. Make sure you are entering arguments--" & vbNewLine & _
" The Date of NAV, " & vbNewLine & _
" the entry found in the right row of NAV workbooks (e.g. 'Net Asset Value'), " & vbNewLine & _
" the right column (e.g. 'Fund')." & vbNewLine & _
" This function will only find exact matches." & vbNewLine & vbNewLine & _
"Now emailing developer to ask for a fix."
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "User attempted" & _
"=FindItemOnWorksheet( " & theDate & ", " & theItemSpecies & ", " & theItemGenus & " )" & vbNewLine & _
"theDate type " & TypeName(theDate) & vbNewLine & _
"theItemSpecies type " & TypeName(theItemSpecies) & vbNewLine & _
"theItemGenus type " & TypeName(theItemGenus)
On Error Resume Next
With OutMail
.To = <Address Removed>
.CC = ""
.BCC = ""
.Subject = "FindItemOnWorksheet Error"
.Body = strbody
'.Attachments.Add ("C:\file.xlsx")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
FindItemOnWorksheet = "Error"
'wb.Close
Exit Function
End Function
Function GetWB(ByVal NAVDate As Date) As Workbook
'Open requested workbook, return to parent procedure
Dim wbPath As String
Dim wbYear As String
Dim wbMonth As String
Dim wbWeek As String
Dim wbFile As String
Dim wbString As String
Dim wb As Workbook
Dim BackADay As Boolean
Dim OriginalNAVDateRequested As Date
OriginalNAVDateRequested = NAVDate
BackADay = True
'Loop through possible file tree structures and dates to find the closest NAV in the past to the date requested.
Do While BackADay = True
'Don't go back to a previous week if cannot find current NAV
If OriginalNAVDateRequested - NAVDate > 4 Then
BackADay = False
End If
wbPath = <Network Path Removed>
wbYear = CStr(Year(NAVDate)) & "\"
wbMonth = MonthName(Month(NAVDate)) & " " & wbYear
wbWeek = DateFormat(NAVDate) & "\"
wbFile = Dir(wbPath & wbYear & wbMonth & wbWeek & "*Valuation Package*.xlsx")
'Pricings with distributions have differing tree structure
If wbFile = "" Then
wbWeek = wbWeek & "POST Distribution " & wbWeek
wbFile = Dir(wbPath & wbYear & wbMonth & wbWeek & "*Valuation Package*.xlsx")
If wbFile = "" Then
NAVDate = NAVDate - 1
Else: BackADay = False
End If
Else: BackADay = False
End If
Loop
wbString = wbPath & wbYear & wbMonth & wbWeek & wbFile
Set wb = Workbooks.Open(wbString, UpdateLinks:=False, ReadOnly:=True)
Set GetWB = wb
End Function
Function DateFormat(ByVal X As Date) As String
'Appends leading zeroes if needed to achieve form "00" for any two digit integer, and converts to string
Dim MM As String
Dim DD As String
Dim YYYY As String
If Month(X) < 10 Then
MM = "0" & CStr(Month(X))
Else
MM = CStr(Month(X))
End If
If Day(X) < 10 Then
DD = "0" & CStr(Day(X))
Else
DD = CStr(Day(X))
End If
YYYY = CStr(Year(X))
DateFormat = MM & "." & DD & "." & YYYY
End Function
You can Open Workbooks within a Worksheet_Change Event.
For demonstration, if a change in Sheet1!A2, Excel will try open the workbook name with that cell value, then Output the status to Sheet1!A4.
Put below in a Module:
Option Explicit
Function TryOpenWB(ByVal oItem As Variant) As Variant
Dim sOut As String
Dim oWB As Workbook
On Error Resume Next
Set oWB = Workbooks.Open(CStr(oItem))
If oWB Is Nothing Then
sOut = "Cannot open """ & CStr(oItem) & """"
Else
sOut = "Opened """ & CStr(oItem) & """ successfully."
'oWB.Close
End If
TryOpenWB = sOut
End Function
Then below in Worksheet Module (I used Sheet1 for demonstration):
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = Range("A2").Address Then
Application.EnableEvents = False
Range("A4").Value = TryOpenWB(Target)
Application.EnableEvents = True
End If
End Sub
So this idea is to open the Workbook only if some cell address is matched.

How to make Looping and Calculate formula from another workbook without open file

I want to ask how to do this from vba code
Workbook 1 contain cell A, cell B, cell C
Workbook 2 contain Cell D
each cell contains number value
Cell D = (Cell A - Cell B) * Cell C
i want to calculate and just return value to cell D in workbook 2, Here my code snippet
Dim path As String
Dim workbookName As String
Dim worksheetName As String
Dim cella As String, cellb As String, cellc As String
Dim returnedValue1 As String, returnedValue2 As String, returnedValue3 As String
Dim Hasil1 As Long
path = "D:\"
workbookName = "Workbook1"
worksheetName = "Daily"
cella = "F7"
cellb = "E7"
cellc = "D7"
returnedValue1 = "'" & path & "[" & workbookName & "]" & _
worksheetName & "'!" & Range(cella).Address(True, True, -4150)
returnedValue2 = "'" & path & "[" & workbookName & "]" & _
worksheetName & "'!" & Range(cellb).Address(True, True, -4150)
returnedValue3 = "'" & path & "[" & workbookName & "]" & _
worksheetName & "'!" & Range(cellc).Address(True, True, -4150)
Worksheets("Workbook2").Cells(D).Value = CLng(ExecuteExcel4Macro(returnedValue1) - ExecuteExcel4Macro(returnedValue2)) * ExecuteExcel4Macro(returnedValue3)
as far my code was good, but how to do it in one column, i have many cell beside just cell A. I want to calculate like this
Column D = (Column A - Column B ) * COlumn C
thanks for your answer..
Something like that (while row in column A is not empty, it populates your expression in column D):
Sub mmacro()
Dim path As String
Dim workbookName As String
Dim worksheetName As String
Dim cella As String, cellb As String, cellc As String, celld As String
Dim returnedValue1 As String, returnedValue2 As String, returnedValue3 As String
Dim Hasil1 As Long
Dim rownum As Integer
Dim A As Integer, B As Integer, C As Integer, D As Integer
path = "D:\tmp\"
workbookName = "Book2"
worksheetName = "Sheet1"
cella = "F"
cellb = "E"
cellc = "D"
celld = "A"
rownum = 3'Data starts in row 3 in my example
Do
returnedValue1 = "'" & path & "[" & workbookName & "]" & _
worksheetName & "'!" & Range(cella & rownum).Address(True, True, -4150)
returnedValue2 = "'" & path & "[" & workbookName & "]" & _
worksheetName & "'!" & Range(cellb & rownum).Address(True, True, -4150)
returnedValue3 = "'" & path & "[" & workbookName & "]" & _
worksheetName & "'!" & Range(cellc & rownum).Address(True, True, -4150)
A = CInt(ExecuteExcel4Macro(returnedValue1))
B = CInt(ExecuteExcel4Macro(returnedValue2))
C = CInt(ExecuteExcel4Macro(returnedValue3))
D = (A - B) * C
Worksheets("Sheet1").Range(celld & rownum).Value = D
rownum = rownum + 1
Loop While Not D = 0
End Sub
This is just example. It is needed to be refined
Further to my comment here is a faster method which DOESN'T use looping. Use ACE.OLEDB to read the 3 columns into a temp sheet and then perform the calculation. Yes, ACE.OLEDB will open the other excel file but it doesn't open it like Excel does.
Note: The below code uses Early binding and please set a reference to the ActiveX Object Data XX.XX Library.
Option Explicit
Sub Sample()
Dim sConn As String
Dim rs As ADODB.Recordset
Dim mySQL As String, sPath As String
Dim wsI As Worksheet, wsO As Worksheet
Dim wsILRow As Long, i As Long
'~~> Change this to the relevant Excel File
sPath = "C:\MyFile.xlsx"
'~~> Change connection string if the above is not xlsx
sConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & sPath & ";" & _
"Extended Properties=Excel 12.0"
'~~> Assuming that workbook 2 has sheet1 from where you want data
mySQL = "SELECT * FROM [Sheet1$A:C]"
Set rs = New ADODB.Recordset
rs.Open mySQL, sConn, adOpenUnspecified, adLockUnspecified
'~~> Create a temp sheeet to get the data from closed file
Set wsI = ThisWorkbook.Sheets.Add
'~~> Dump the data in the temp sheet
wsI.Range("A1").CopyFromRecordset rs
'~~> Close the recordset
rs.Close
sConn.Close
Set rs = Nothing
Set sConn = Nothing
'~~> Get last row from temp sheet
wsILRow = wsI.Range("A" & wsI.Rows.Count).End(xlUp).Row
'~~> This is where you want the output
Set wsO = ThisWorkbook.Sheets("Sheet1")
With wsO
'~~> Insert values in one go
.Range("D1:D" & wsILRow).Formula = "=(" & wsI.Name & "!A1 - " & _
wsI.Name & "!B1) * " & _
wsI.Name & "!C1"
'~~> Change formulas to values
.Range("D1:D" & wsILRow).Value = .Range("D1:D" & wsILRow).Value
End With
'~~> Delete tmep sheet
On Error Resume Next
Application.DisplayAlerts = False
wsI.Delete
Application.DisplayAlerts = False
On Error GoTo 0
End Sub