Hello Everyone,
I'm having an issue with the macro below, I know its messy, I like to get it working before tidying
Basically it all pretty much works fine except on the second or third file that it tries to open it tries to open the previous file, meaning it cant find it. Any help would be great.
I'm having an issue with the macro below, I know its messy, I like to get it working before tidying
Basically it all pretty much works fine except on the second or third file that it tries to open it tries to open the previous file, meaning it cant find it. Any help would be great.
Rich (BB code):
Sub test2()
Dim DateFind As String
Dim StartR As String
Dim EndR As String
Dim StaffID As String
Dim Score1 As String
Dim Text1 As String
Dim Score2 As String
Dim Text2 As String
Dim Score3 As String
Dim Text3 As String
Dim Score4 As String
Dim Text4 As String
Dim AorR As String
Dim StartD As String
Dim ComD As String
Dim Pref As String
Dim Budg As String
Dim ComText As String
Dim Score As String
Dim ScoPer As String
Dim Time As String
Dim MyPath As String
Dim MyFile As String
Dim LatestFile As String
Dim LatestDate As Date
Dim LMD As Date
Dim Email1 As String
Dim FromPath As String
Dim ToPath As String
Dim FSO As Object
Dim FileExt As String
Dim StrFile As String
Dim R1 As String
On Error Resume Next
'Set MyPath
MyPath = "FILEPATHHERE"
Workbooks("Test Results.xlsm").Activate
StrFile = Dir(MyPath)
Do While Len(StrFile) > 0
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''' Set File Paths and ''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''' run through files ''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
1
'Set From and To Path
FromPath = "FILEPATHHERE"
ToPath = "FILEPATHHERE"
'Open File
'Make sure that the path ends in a backslash
If Right(MyPath, 1) <> "" Then MyPath = MyPath & ""
'Get the first Excel file from the folder
MyFile = Dir(MyPath & "*.xls", vbNormal)
'If no files were found, exit the sub
If Len(MyFile) = 0 Then
MsgBox "No more files were found...", vbExclamation
Exit Sub
End If
'Loop through each Excel file in the folder
Do While Len(MyFile) > 0
'Assign the date/time of the current file to a variable
LMD = FileDateTime(MyPath & MyFile)
'If the date/time of the current file is greater than the latest
'recorded date, assign its filename and date/time to variables
If LMD > LatestDate Then
LatestFile = MyFile
LatestDate = LMD
End If
'Get the next Excel file from the folder
MyFile = Dir
'*'*'*'*'*'*'*'*'*'*'* End of file finder '*'*'*'*'*'*'*'*'*'*'*'*'
'Open and Activate File
On Error GoTo 1
Workbooks.Open MyPath & LatestFile
Workbooks(LatestFile).Activate
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''' Copy Data from PQR ''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''' into results ''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Copy data into Form tab
Cells.Select
Range("A1").Activate
Selection.Copy
Windows("Test Results.xlsm").Activate
Sheets("Form").Select
Cells.Select
Range("A13").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Set data to paste
On Error GoTo ErrHandler
Sheets("Information").Select
Score1 = Range("B4").Value
Text1 = Range("B5").Value
Score2 = Range("B6").Value
Text2 = Range("B7").Value
Score3 = Range("B4").Value
Text3 = Range("B9").Value
Score4 = Range("B10").Value
Text4 = Range("B11").Value
AorR = Range("B12").Value
StartD = Range("B13").Value
ComD = Range("B14").Value
Pref = Range("B15").Value
Budg = Range("B16").Value
ComText = Range("B17").Value
Score = Range("B18").Value
ScoPer = Range("B19").Value
Time = Range("B20").Value
'Set the Staff
Sheets("Information").Select
Range("B3").Select
StaffID = Selection.Value
'Set the date
Range("B23").Select
DateFind = Selection.Text
'Find the Date to set the range
Sheets("Ranges").Select
Range("A1").Select
Cells.Find(What:=DateFind, After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Selection.Offset(0, 3).Select
StartR = Selection.Value
Selection.Offset(0, 1).Select
EndR = Selection.Value
'Select the range and find worker
Sheets("All").Select
Rows(StartR & ":" & EndR).Select
Selection.Find(What:=StaffID, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Select
'Check that nothing will be overidden, if so close file
Selection.Offset(0, 1).Select
R1 = ActiveCell.Row
Range("F" & R1).Select
If Not Selection.Value = "" Then
MsgBox ("This PQR has allready been submitted" & vbNewLine & StaffID)
Workbooks(LatestFile).Close savechanges:=False
Exit Sub
End If
'Paste Data
'Section1
Selection.Value = Score1
Selection.Offset(0, 1).Select
Selection.Value = Text1
'Section2
Selection.Offset(0, 1).Select
Selection.Value = Score2
Selection.Offset(0, 1).Select
Selection.Value = Text2
'Section3
Selection.Offset(0, 1).Select
Selection.Value = Score3
Selection.Offset(0, 1).Select
Selection.Value = Text3
'Section4
Selection.Offset(0, 1).Select
Selection.Value = Score4
Selection.Offset(0, 1).Select
Selection.Value = Text4
'AorR
Selection.Offset(0, 1).Select
Selection.Value = AorR
'StartD
Selection.Offset(0, 1).Select
Selection.Value = StartD
'ComD
Selection.Offset(0, 1).Select
Selection.Value = ComD
'Pref
Selection.Offset(0, 1).Select
Selection.Value = Pref
'Budg
Selection.Offset(0, 1).Select
Selection.Value = Budg
'ComText
Selection.Offset(0, 1).Select
Selection.Value = ComText
'Score
Selection.Offset(0, 1).Select
Selection.Value = Score
'ScoPer
Selection.Offset(0, 1).Select
Selection.Value = ScoPer
'Time
Selection.Offset(0, 1).Select
Selection.Value = Time
'Email file
Workbooks(LatestFile).Activate
Email1 = "emailaddresshere"
'Send in email
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
On Error Resume Next
With OutMail
.To = Email1
.CC = ""
.BCC = ""
.Subject = ""
.Body = ""
.Attachments.Add ActiveWorkbook.FullName
'Change Item(#)to the account number that you want to use
.SendUsingAccount = OutApp.Session.Accounts.Item(2)
.Send
End With
'Close Workbook
Workbooks(LatestFile).Close savechanges:=False
'Save File into Sent
If Right(FromPath, 1) <> "" Then
FromPath = FromPath & ""
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
If FSO.FolderExists(ToPath) = False Then
MsgBox ToPath & " doesn't exist"
Exit Sub
End If
FSO.moveFile Source:=FromPath & LatestFile, Destination:=ToPath
Loop
Loop
IfError: MsgBox "Completed, please check sent items", vbInformation
Exit Sub
'ErrHandler
ErrHandler: MsgBox ("Error has occured with" & vbNewLine & StaffID)
End Sub
Last edited by a moderator:
