I am trying to isolate the address changes I have gotten from a folder containing a series of files with names containing the address changes. See the first image I included as an example of the folder I am drawing from. I iterate through the folder and output the to an excel sheet the original address and the new address to excel. The issue I am encountering is that not all file names are the same so I currently cannot draw the correct address change information from the filenames. The second photo included is a photo of the output, the files in yellow are the filenames that my script cannot iterate for. If anyone has any suggests on how to broaden the number of cases I can deal with it would be very helpful see current code below.
Dim AddChng As Worksheet
If sheetExists("AddressChange") Then 'create a new sheet if one doesn't exist
Set AddChng = ThisWorkbook.Sheets("AddressChange")
Else
Set AddChng = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
AddChng.Name = "AddressChange"
End If
AddChng.UsedRange.Delete shift:=xlUp 'clear the sheet
AddChng.Range("A1").Value = "Old Name" 'set up
AddChng.Range("B1").Value = "New Name"
AddChng.Activate
AddChng.Range("A2").Select
Dim StrFile As String
'Change this to the directory containing all Address Change Circulation emails
'This will Pull in a list and, to the best of its ability make two columns that hold the data for
'the old and the new address
StrFile = Dir(Range("AddressChangeFolderPath").Value)
Dim Names() As String
Dim StrName
Do While Len(StrFile) > 0
CheckVal = InStr(1, StrFile, "Address Change Circulation -", vbTextCompare) + _
InStr(1, StrFile, "Address Change Circulation from ", vbTextCompare)
If CheckVal <> 1 Then 'if the email does not fit the standard, just place it in the cell and
'move on to the next entry
Selection.Value = StrFile
Selection.Interior.Color = RGB(255, 255, 0) 'highlight the cell
Selection.Offset(1, 0).Select
Else
StrName = Right(StrFile, Len(StrFile) - 29) 'trim to the correct size - probably not the
'best way to do this but it works
If Left(StrName, 4) = "from" Then
StrName = Right(StrName, Len(StrName) - 5)
ElseIf Left(StrName, 2) = "om" Then
StrName = Right(StrName, Len(StrName) - 3)
End If
StrName = Left(StrName, Len(StrName) - 4)
Changes = Split(StrName, " and ")
For Each Change In Changes
Names = Split(Change, " to ")
If Len(Names(0)) < 5 Then
Selection.Value = Names(0) & Right(Names(1), Len(Names(1)) - Len(Names(0)))
Else
Selection.Value = Names(0)
End If
If UBound(Names) >= 1 Then 'this is a zero indexed array, checking greater than or
'equal to 1 will check if there are two or more entries
Selection.Offset(0, 1).Value = Names(1) ' in the event that there is no " to " in
'the file name and it hasn't been handeled already
End If
Selection.Offset(1, 0).Select 'select the next cell to accept the next entry
Next
End If
StrFile = Dir
Loop
MsgBox "Make sure to QAQC the new table and update any fields that haven't been properly " & _
"filled in by the automation."
End Sub
".. not all file names are the same so .." I would hope so.
You obviously have to add "Address Change from" to the "CheckVal = .." instruction. AND add all other possible variations!
I suggest you check for each individual case individually and handle each case individually. To handle all cases in one "else" has to be wrong. IMHO.
Related
im trying to create a macro for adding text to a field
i want when i click the checkmark to add a specific text to a case
i have 8 checkbox each one will add a different text to the same case
right now my code look like this
Private Sub CheckBox1_Click()
If Me.CheckBox1.Value = True Then
Range("A56").Value = "Test"
Else
Range("A56").Value = " "
End If
End Sub
the problem is if i check 2 checkmark it always replace the text and i want it to add the text not replace it. and also when i uncheck the checkmark it remove everything in the case
the reason why i need it is to save time not having to write them manualy each time
i am very new to excel coding i apreciated any help you guys can give me
thanks a lot for ur time
So the first part:
Range("A56").value = Range("A56").value & " Text"
The second part I'm assuming the real entries are more substantial than "Test" otherwise you might get some false positives, but this should work pretty well:
Private Sub CheckBox1_Click()
With Sheet1 'Change this to the proper sheet codename
If Me.CheckBox1.Value = True Then
.Cells(56, 1).Value = .Cells(56, 1).Value & " Testing"
Else
If InStr(1, .Cells(56, 1).Value, " Testing") Then
Dim splitarr As Variant
splitarr = Split(.Cells(56, 1).Value, " Testing")
Dim element As Variant
.Cells(56, 1).Value = ""
For Each element In splitarr
.Cells(56, 1).Value = .Cells(56, 1).Value & element
Next element
End If
End If
End With
End Sub
You might want to make the entered or deleted string a variable so it is easier to change.
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
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
I am creating a code that opens and imports data from a file that is selected based on a client's name. Each time a client is opened, a file is saved for them with their name and date of birth (without slashes).
A sample file would look like C:\Data\Clients\John Doe 01011900.xlsx. An InputBox on button-click provides a client's name, but what I'm getting stuck on is if there are 2 or more John Does in the folder.
Check = Application.InputBox(prompt:="What is your client's first and last name?", Type:=2)
FilePath = "C:\Data\Clients\" & Check & "*.xlsx"
If Dir(FilePath, vbDirectory) = "" Then
Exit Sub
End If
DOB = MsgBox("Is this your client's date of birth? " & " " & Chr(149) & " " & Mid(Dir(FilePath), Len(Dir(FilePath)) - 12, 2) & "/" & Mid(Dir(FilePath), Len(Dir(FilePath) - 10, 2) & "/" & Mid(Dir(FilePath), Len(Dir(FilePath) - 8, 4) & " " & Chr(149), vbYesNoCancel)
If DOB = vbYes Then
Workbooks.Open (FilePath)
'Transfer Data
ActiveWorkbook.Close False
ElseIf DOB = vbNo Then
'Try again.
ElseIf DOB = vbCancel Then
'Do nothing.
End If
My confusion is occurring at the DOB = vbNo, when someone says the date of birth does not match (meaning the next client with the same name needs to be selected). Everything else works great so far, so I just need help with the re-selection of the next file with the same name.
You can loop through all the matches by adding a strDir = Dir at the end of your loop, which will exit after the match is met and not accepted (as the length of StrDir will be 0)
update
I realise the code looks a little strange but this is the way Dir works, ie each time it is called it looks for the same match as the initial Dir until it reaches the end of the list. See Loop through files in a folder using VBA?
ie
Do While Len(strDir) > 0
DOB = MsgBox("Is this your client's date of birth?", vbYesNoCancel)
If DOB = vbCancel Then Exit Do
If DOB = vbYes Then
Workbooks.Open (filepath)
ActiveWorkbook.Close False
Exit Do
End If
strDir = Dir
Loop
This is what I would do:
First, use string comparison to find all the files in the directory that starts with John Doe and store them in a dynamic array.
Use For...Each statement to go through the files, and use
Dir(FilePath) LIKE "John Doe*" to find your candidates.
Then use a Do...While loop to go through the files in the array until you find your match.
I could write the entire code for you but then you'd miss all the fun...
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.