Excel VBA For Loop and Nested IF statements for Counter - excel

I have a value in a cell that should match the filename of a document in a directory.
Sheet3 Column A1 = C:\Users\Admin\Desktop\Folder1
Sheet3 Column A2 = test.xls
‘Location of directory
sCurrentXLDirectory = Worksheets("Sheet3").Cells(1, 1).Value
Set CurrentXLFSO = CreateObject("Scripting.FileSystemObject")
ProceedNow = True
Set CurrentXLFolder = CurrentXLFSO.GetFolder(sCurrentXLDirectory)
Set CurrentXLFiles = CurrentXLFolder.Files
‘Always 10 files in this folder
If CurrentXLFiles.Count <> 10 Then
MsgBox "Wrong Directory or Folder Mismatch"
ProceedNow = False
Else
'Return one for indentical filename
Dim NameCount As Integer
NameCount = 0
For Each folderIDX In CurrentXLFiles
‘Compare file names specified cell value
If folderIDX.Name = Worksheets("Sheet3").Cells(1, 2).Value Then
NameCount = NameCount + 1
If NameCount <> 1 Then
MsgBox "Unable to find file”
ProceedNow = False
End If
End If
Next
End If
For some reason, even if I change test.xls to test1.xls, it will still do Proceed = True
If a nested IF statement is not the preferable way to do this, please guide me in the right direction.

If the purpose of the procedure is verify if a file exists or does not exist, using the Dir() function would be much simpler.
If this is the goal, try the following code:
Sub test()
Dim sDirectory As String
Dim sFile As String
sDirectory = Worksheets("Sheet3").Cells(1, 1).Value
sFile = Worksheets("Sheet3").Cells(1, 2).Value
sFile = Dir(sDirectory & "\" & sFile, vbDirectory)
If Len(sFile) = 0 Then
MsgBox "Unable to find file"
End If
End Sub

The code you provided will not change a file name, so maybe this is just the beginnings of your attempt. What I found, though, is that Range("A2") is "Cells(2, 1)", not "Cells(1, 2)", as you currently have it. You are referencing cell B1, which probably does not contain a file name.
To alleviate such confusion in the future, always refer to one or the other, then such problems are avoided or easily diagnosed.
Such as:
If folderIDX.Name = Worksheets("Sheet3").Range("A2").Value Then
This should trip that "ProceedNow = False" flag that you are looking for.

Related

How to get this array code to output into my message box correctly?

I have a spreadsheet that users can interact with to specify the file path to 4 different files needed to be opened to run some macros. The code includes a check to see if the file path they have entered is valid or not (works excellently). However, what I want to do is have a message box appear if anything doesn't work and then also tell the user which one didn't work.
My code does do that perfectly (albeit in I think a quite convoluted way) however as the array is set to have 4 values it means if the final file isn't present, it starts the text 4 lines down in the message box instead of at the top.
What I want to do, I believe, is ReDim the array to only the amount of files missing so that the MsgBox isn't 3 empty lines below the first sentence. I've kinda figured that bit out but I just could not get it working properly and now I am stumped.
Sub Open_month_0()
On Error GoTo ErrHand
ThisWorkbook.ActiveSheet.Calculate
Dim i As String
Dim j As String
Dim k As String
Dim l As String
Dim m As String
Dim n As String
Dim o As String
Dim p As String
Dim arr(4) As Variant
Dim File_Missing As Integer
'Used as a counter to prompt either an error or successful result
File_Missing = 0
i = Range("LUX_Full_file_path")
j = Range("LUX_Full_file_name")
k = Range("JUP_Full_file_path_M")
l = Range("JUP_Full_file_name_M")
m = Range("JUP_Full_file_path_Q")
n = Range("JUP_Full_file_name_Q")
o = Range("JUP_Full_file_path_A")
p = Range("JUP_Full_file_name_A")
'The if not's check to see if the file path is valid. If it isn't, gets added to array and File_missing begins
If Not Dir(i, vbDirectory) = vbNullString Then
Workbooks.Open (i)
Windows(j).Visible = False
Else
arr(1) = "Lux file"
File_Missing = File_Missing + 1
End If
If Not Dir(k, vbDirectory) = vbNullString Then
Workbooks.Open (k)
Windows(l).Visible = False
Else
arr(2) = "Monthly file"
File_Missing = File_Missing + 1
End If
If Not Dir(m, vbDirectory) = vbNullString Then
Workbooks.Open (m)
Windows(n).Visible = False
Else
arr(3) = "Quarterly file"
File_Missing = File_Missing + 1
End If
If Not Dir(o, vbDirectory) = vbNullString Then
Workbooks.Open (o)
Windows(p).Visible = False
Else
arr(4) = "Annual file"
File_Missing = File_Missing + 1
End If
'Basic error handling procedure that retains function.
If File_Missing > 0 Then
MsgBox ("The following files could not be found. Please check the file paths and try again" & vbCrLf & Join(arr, vbCrLf))
Else
MsgBox "Files opened successfully."
End If
Exit Sub
ErrHand: MsgBox "There has been a critical error with opening the chosen workbooks. If the problem persists, please contact your administrator for assistance."
End Sub
Edit with pictures:
A screenshot of the message box current output
How I'd like the message box to look
Since you just use that array to Join it later you could also just use a String variable MyMissingFiles instead of that array and append the file name.
You even don't need to count the files in File_Missing if this number is not of your interest.
Dim MyMissingFiles As String
If Not Dir(i, vbDirectory) = vbNullString Then
Workbooks.Open (i)
Windows(j).Visible = False
Else
MyMissingFiles = MyMissingFiles & vbCrLf & "Lux file"
End If
' … all the others accordingly here …
If MyMissingFiles <> vbNullString Then
MsgBox ("The following files could not be found. Please check the file paths and try again" & MyMissingFiles)
Else
MsgBox "Files opened successfully."
End If

Using function to open and update values in external workbooks, but returning source errors

I've been using a function from another StackOverflow question (I'm SO sorry I can't find the original answer!) to help go through a number of cells in Column L that contains a formula that spits our a hyperlinked filepath. It is meant to open each one (workbook), update the values, then save and close the workbook before opening the next one. See below.
Sub List_UpdateAndSave()
Dim lr As Long
Dim i As Integer
Dim WBSsource As Workbook
Dim FileNames As Variant
Dim msg As String
' Update the individual credit models
With ThisWorkbook.Sheets("List")
lr = .Cells(.Rows.Count, "L").End(xlUp).Row
FileNames = .Range("L2:L" & lr).Value
End With
For i = LBound(FileNames, 1) To UBound(FileNames, 1)
On Error Resume Next
If FileNames(i, 1) Like "*.xls*" Then
Set WBSsource = Workbooks.Open(FileNames(i, 1), _
ReadOnly:=False, _
Password:="", _
UpdateLinks:=3)
If Err = 0 Then
With WBSsource
'do stuff here
.Save
.Close True
End With
Else
msg = msg & FileNames(i, 1) & Chr(10)
On Error GoTo 0
End If
End If
Set WBSsource = Nothing
Next i
If Len(msg) > 0 Then
MsgBox "The Following Files Could Not Be Opened" & _
Chr(10) & msg, 48, "Error"
End If
End Sub
The problem now is I am using this to work on a Network drive, and as a result it cause pathing issues with the Connections/Edit Links part. Each of the files are stored on S:\... which as a result of using the Hyperlink formula, won't be able to find the source data. See below the example image of a file that as been opened through a hyperlink cell from my original workbook. When I go to update the Edit Links section of it, it shows these errors.
If I open that lettered drive in Windows Explorer and find the file, it works with no problems. Open, Update Values > Save > Close, it says unknown...
(but if I click Update values here they update correctly.)
If opened using a Hyperlink formula in a cell (Also directing to S:\..) it says it contains links that cannot be updated. I choose to edit links and they're all "Error: Source not found". The location on them also starts off with \\\corp\... and not S:\.
Anyway to fix this? Apologies for the long winded question.
I'm adding this as an answer as it contains code and is a bit long for a comment.
I'm not sure if it's what you're after though.
The code will take the mapped drive and return the network drive, or visa-versa for Excel files. DriveMap is the variable containing the final string - you may want to adapt into a function.
Sub UpdatePath()
Dim oFSO As Object
Dim oDrv As Object
Dim FileName As String
Dim DriveMap As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
FileName = Range("A1")
If InStr(oFSO.GetExtensionName(FileName), "xls") > 0 Then
For Each oDrv In oFSO.drives
If oDrv.sharename <> "" Then
'Changes \\corp\.... to S:\
If InStr(FileName, oDrv.sharename) = 1 Then
DriveMap = Replace(FileName, oDrv.sharename, oDrv.Path)
End If
'Changes S:\ to \\corp\....
' If InStr(FileName, oDrv.Path) = 1 Then
' DriveMap = Replace(FileName, oDrv.Path, oDrv.sharename)
' End If
End If
Next oDrv
End If
End Sub

VBA vlookup data from another workbook

Trying to vlookup from another workbook(its name I search in a certain folder upfront). I got error message Unable to get Vlookup property of the WorksheetFunction class.
I added watches to see if I have meaningful variables.
Tried to put Thisworkbook. in front of sh_main but it does't work either. I don't know what do I do wrongly, any help highly appreciated!
Sub Actual_inventory()
Assignments1
Dim directory As String, fileName As String, i As Integer
Dim col_unrestricted As String
Dim range_temp2 As Range
Application.ScreenUpdating = False
directory = "C:\Users\marcellh\Documents\Reports\Actual\"
fileName = Dir(directory & "*.xl??")
Workbooks.Open (directory & fileName)
'converts column A to number format:
Range("A:A").Select
With Selection
.NumberFormat = "General"
.Value = .Value
End With
'searches column "unrestricted":
Set range_temp2 = Workbooks(fileName).Sheets(1).Cells.Find("unrestricted")
col_unrestricted = range_temp2.Column
'---
i = first_data_set
Do While sh_main.Cells(i, col_color).Value <> ""
'vlookups based on old gmid, iferror then "":
sh_main.Cells(i, col_inventory_old_gmid).Value = Application.WorksheetFunction.VLookup(sh_main.Cells(i, col_old_gmid_code).Value, Workbooks(fileName).Sheets(1).Range("A:L"), col_unrestricted, False)
If IsError(sh_main.Cells(i, col_inventory_old_gmid).Value) Then
sh_main.Cells(i, col_inventory_old_gmid).Value = ""
End If
'vlookups based on new gmid, iferror then "":
sh_main.Cells(i, col_inventory_new_gmid).Value = Application.WorksheetFunction.VLookup(sh_main.Cells(i, col_new_gmid_code).Value, Workbooks(fileName).Sheets(1).Range("A:L"), col_unrestricted, False)
If IsError(sh_main.Cells(i, col_inventory_new_gmid).Value) Then
sh_main.Cells(i, col_inventory_new_gmid).Value = ""
End If
i = i + 1
Loop
Workbooks(fileName).Close
fileName = Dir()
Application.ScreenUpdating = True
MsgBox "Actual inventory has been loaded successfully"
End Sub
This is where the macro stucks with the error message:

VBE macro that creates shortcuts which include the autor of the linked file as property

this is my first question so I would love to improve my style and such. Just tell me if I am doing something completely wrong.
My question:
I am searching files with a specific extensions. All results get printed to excel and then create shortcuts to each file which get then stored in a folder. This works perfectly fine for now, but I need the shortcut to include the author detail to filter all entries (hundreds to thousends) for it.
The result should be a shortcut with the same properties that you get when using the 'create shortcut' from context menu vie right click.
I hope you can help my since I am trying to get this to work for a while now.
If you know a solution, that does what I need but is maybe written in a different language that is fine for me as long as the user does not have to install runtimes/libraries (sory I am a complete beginner)
My code:
'This function searches for files with endings (ppt,pptx,pptm) and pastes the found entries into the excel sheet
Function Recurse(sPath As String) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim mySubFolder As Folder
Dim myFile As File
Set myFolder = FSO.GetFolder(sPath)
Set Extensions = CreateObject("Scripting.Dictionary")
Extensions.CompareMode = 1 ' make lookups case-insensitive
'Extensions.Add Range("C5").Value, True
Extensions.Add "pptx", True
Extensions.Add "ppt", True
Extensions.Add "pptm", True
For Each mySubFolder In myFolder.SubFolders
For Each myFile In mySubFolder.Files
'
i = Range("D4").Value
If Extensions.Exists(FSO.GetExtensionName(myFile)) Then
Cells(8 + i, 3).Value = myFile.Name
Cells(8 + i, 4).Value = myFile.Path
i = i + 1
Range("D4").Value = i 'storing number of entrys found
'Exit For
End If
Next
Recurse = Recurse(mySubFolder.Path)
Next
End Function
'This Function creates a folder with the name "A1" if it does not exist already
Function PathExist(ByVal vPfadName As String) As Boolean
scutPath = Application.ActiveWorkbook.Path & "\" & Range("A1").Value
On Error GoTo ErrorPathExist
ChDir (vPfadName)
PathExist = True
Exit Function
ErrorPathExist:
MkDir scutPath
End Function
'Main Function that clears table and uses the found entries to get create shortcuts. Unfortunately the author is not integrated when doing it this way. The author is necessary to filter through hundreds of results.
Sub TestR()
Range("B8:C999999") = ""
Range("D4").Value = 0
Call Recurse(Application.ActiveWorkbook.Path)
i = 1
scutPath = Application.ActiveWorkbook.Path & "\" & Range("A1").Value
Call PathExist(scutPath)
For i = 1 To 200 '(last line)
Set oWSH = CreateObject("WScript.Shell")
Set oShortcut = oWSH.CreateShortCut(scutPath & "\" & Cells(7 + i, 3).Value & ".lnk")
With oShortcut
.TargetPath = Cells(7 + i, 4).Value
.Save
End With
Set oWSH = Nothing
Next i
MsgBox "Done"
End Sub

cannot retrieve column titles from another workbook

I am trying to copy the string values(column titles) from another workbook in row 4 as captions for checkboxes in the workbook where I am running the code. This is what I have so far and it is not working because it is showing the error message "Subscript out of range, run time error 9" Here is what I have. After the error message pops up the line marked below is highlighted. Can anybody help me please. Thank you very much.
Function CallFunction(SheetName As Variant) As Long
Dim text As String
Dim titles(200) As String ' Dim titles(200) As String ' Array
Dim nTitles As Integer
Dim wks As Worksheet
Dim myCaption As String
PathName = Range("F22").Value
Filename = Range("F23").Value
TabName = Range("F24").Value
ControlFile = ActiveWorkbook.Name
Workbooks.Open Filename:=PathName & "\" & Filename
ActiveSheet.Name = TabName
Set wks = Workbooks("Filename").Worksheets(SheetName).Activate ' <= Highlights this line ****
For i = 1 To 199
If Trim(wks.Cells(4, i).Value) = "" Then
nTitles = i - 1
Exit For
End If
titles(i - 1) = wks.Cells(4, i).Value
Next
i = 1
For Each cell In Range(Sheets("Sheet1").Cells(4, 1), Sheets("Sheet1").Cells(4, 1 + nTitles))
myCaption = Sheets("Sheet1").Cells(4, i).Value
With Sheets("Sheet1").checkBoxes.Add(cell.Left, _
cell.Top, cell.Width, cell.Height)
.Interior.ColorIndex = 12
.Caption = myCaption
.Characters.text = myCaption
.Border.Weight = xlThin
.Name = myCaption
End With
i = i + 1
Next
End Function
Subscript out-of-range typically indicates that a specified Worksheet does not exist in the workbooks Worksheets collection.
Otherwise, are you sure that the workbook specified by FileName is already open? If not, that will raise the same error.
Ensure that A) the file is already open (or use the Workbooks.Open method to open it), and B) ensure that such a worksheet already exists (if not, you will need to create it before you can reference it by name).
Update
You have Workbooks("FileName") where "Filename" is a string literal. Try changing it to simply Filename (without the quotation marks) (this seems like the OBVIOUS error).
Also worth checking:
I also observe this line:
ActiveSheet.Name = TabName
If the sheet named by SheetName is active when the workbook opens, then that line will effectively rename it, so you will not be able to refer to it by SheetName, but instead you would have to refer to it by Worksheets(TabName). ALternatively, flip the two lines so that you activate prior to renaming:
Set wks = Workbooks(Filename).Worksheets(SheetName).Activate
ActiveSheet.Name = TabName
For further reading: avoid using Activate/Select methods, they are confusing and make your code harder to interpret and maintain:
How to avoid using Select in Excel VBA macros
If that is the case, then you could do simply:
Workbooks(Filename).Worksheets(SheetName).Name = TabName

Resources