VBA Problems...

Blytheee

New Member
Joined
Dec 3, 2015
Messages
8
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.
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:

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
Hi,

As I read down your code, I am stopped at this line:

Code:
'Make sure that the path ends in a backslash
If Right(MyPath, 1) <> "" Then MyPath = MyPath & ""

Should be:

Code:
'Make sure that the path ends in a backslash
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"

Perhaps that change will get you further along...
 
Upvote 0
Thanks igold,

I think I must've noticed that as I've corrected it at some point. No luck so far, still working away at it.........

Matt
 
Upvote 0

Forum statistics

Threads
1,223,909
Messages
6,175,315
Members
452,634
Latest member
cpostell

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top