I am trying to retrieve the attributes for roughly 500 CAGE codes from the DLA and record them in my spreadsheet. I've been able to get it to work for one iteration, but, on second iteration, get the error "method navigate of object iwebbrowser2 failed"
Note the code doesn't work unless you've already opened the website before and haven't closed the browser (you need to accept the terms and conditions).
The cell B2 = https://cage.dla.mil/Search/Results?q=07187&page=1
The cell B3 = https://cage.dla.mil/Search/Results?q=00198&page=1
Sub NSCM2()
'Initialize
Dim IE As Object
Dim CAGE As String
Dim rowNeeded As String
Dim i As Integer
Dim sDD0 As String
Dim sDD1 As String
Dim sDD2 As String
Dim sDD3 As String
Dim sDD4 As String
Dim Doc As HTMLDocument
'Create IE Object
Set IE = CreateObject("INTERNETEXPLORER.APPLICATION")
'Loop for All Codes
For i = 1 To 10
'Retrieve CAGE Code
rowNeeded = CStr(i + 1)
CAGE = Range("B" & rowNeeded).Value
'Navigate to Cage Code general Page
IE.navigate CAGE
'Wait
Do
DoEvents
Loop Until IE.readyState = 4
Application.Wait (Now + TimeValue("0:00:03"))
'Follow link to details page
For Each ele In IE.document.getElementsByTagName("a")
If InStr(ele.innerText, "Details") > 0 Then ele.Click
Next
'Wait
Do
DoEvents
Loop Until IE.readyState = 4
Application.Wait (Now + TimeValue("0:00:03"))
'Pull needed values
Set Doc = IE.document
sDD0 = Doc.getElementsByTagName("span")(11).innerText
sDD1 = Doc.getElementsByTagName("span")(15).innerText
sDD2 = Doc.getElementsByTagName("span")(17).innerText
sDD3 = Doc.getElementsByTagName("span")(19).innerText
sDD4 = Doc.getElementsByTagName("span")(20).innerText
'Close IE
IE.Quit
'Insert URL
Range("F" & rowNeeded) = sDD0
'Insert Address, comma separated
If sDD1 = "" And sDD2 = "" And sDD3 = "" Then
Range("G" & rowNeeded) = sDD4
ElseIf sDD1 = "" And sDD2 = "" Then
Range("G" & rowNeeded) = sDD3 & ", " & sDD4
ElseIf sDD1 = "" And sDD3 = "" Then
Range("G" & rowNeeded) = sDD2 & ", " & sDD4
ElseIf sDD1 = "" Then
Range("G" & rowNeeded) = sDD2 & "," & sDD3 & ", " & sDD4
Else
Range("G" & rowNeeded) = sDD1 & ", " & sDD2 & ", " & sDD3 & ", " & sDD4
End If
'Insert Address Check
Range("H" & rowNeeded) = sDD1 & ";" & sDD2 & ";" & sDD3 & ";" & sDD4
Next i
End Sub
The first time through the loop, you call
IE.Quit
so your loop will fail on the second iteration
Related
Hello Everyone i was wondering if anyone can help me resolve my problem., i have got code which i found from the net which is working absolutely perfect however only problem is that when there is more than one due date in the column it will send email each time instead of sending all due date and names in One email at same time. Names it is on column A, Expiry Date it is in column E, and email stamp as sent in Column F, below its the code.
Private Sub Workbook_Open()
Dim Email As String, Subj As String, Msg As String, wBox As String
Dim RowNo As Long, i As Long, ky As Variant, cad As Variant
Dim wsEmail As Worksheet, OutApp As Object, OutMail As Object, dic As Object
Set wsEmail = ThisWorkbook.Sheets("Tracker")
Set dic = CreateObject("scripting.dictionary")
With wsEmail
For RowNo = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
If .Cells(RowNo, "E") <> "" Then
If .Cells(RowNo, "F") = "" And .Cells(RowNo, "E") <> "" And .Cells(RowNo, "E") <= Date + 60 Then
If dic.exists(.Cells(RowNo, "F").Value) Then
dic(.Cells(RowNo, "A").Value) = dic(.Cells(RowNo, "A").Value) & RowNo & "|"
Else
dic(.Cells(RowNo, "A").Value) = RowNo & "|"
End If
End If
End If
Next
For Each ky In dic.keys
cad = Left(dic(ky), Len(dic(ky)) - 1)
cad = Split(cad, "|")
wBox = ""
dBox = ""
For i = 0 To UBound(cad)
wBox = wBox & " " & wsEmail.Cells(cad(i), "A")
dBox = wsEmail.Cells(cad(i), "E")
.Cells(cad(i), "F") = "Sent"
.Cells(cad(i), "G") = Environ("username")
.Cells(cad(i), "H") = "E-mail sent on: " & Now()
Next
On Error Resume Next
Set OutApp = GetObject("Outlook.Application")
On Error GoTo 0
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
Do: Loop Until Not OutApp Is Nothing
Set OutMail = OutApp.CreateItem(0)
With OutMail
Subj = wBox & Space(1) & "from will expire soon"
Msg = "Hi" & vbCrLf & vbCrLf _
& "This is an automated e-mail to let you know that" & wBox & Space(1) & " will expire as follow;" & vbCrLf & vbCrLf _
& "Expiry date:" & dBox & vbCrLf & vbCrLf & "Many Thanks " & vbCrLf _
& vbCrLf & "Kind Regards" & vbCrLf & vbCrLf & Environ("username")
.To = "Sent to"
.CC = ""
.BCC = ""
.Subject = Subj
.ReadReceiptRequested = False
.Body = Msg
.Display
End With
mystring = ("Email has been sent for below staff;") & _
vbCrLf & vbCrLf & ky
MsgBox mystring
Set OutApp = Nothing
Set OutMail = Nothing
Next
End With
End Sub
is there any way to do this?
This should get you started.
Read the code's comments and adjust it to fit your needs.
Private Sub SendEmails()
Dim trackerSheet As Worksheet
Set trackerSheet = ThisWorkbook.Worksheets("CTCTracker")
Dim lastRow As Long
lastRow = trackerSheet.Cells(trackerSheet.Rows.Count, "A").End(xlUp).Row
Dim trackerRange As Range
Set trackerRange = trackerSheet.Range("A5:A" & lastRow)
' Declare boolean to check if there are any expiring names
Dim anyExpiring As Boolean
Dim nameCell As Range
For Each nameCell In trackerRange
' Check: 1) There is a expiring date
' 2) Email not sent yet
' 3) Expiring date less than today + 60 días
If nameCell.Offset(0, 4).Value <> "" And _
nameCell.Offset(0, 5).Value = "" And _
nameCell.Offset(0, 4).Value <= Date + 60 Then
' Store names and expiring dates into array
Dim infoArray() As Variant
Dim counter As Long
ReDim Preserve infoArray(counter)
infoArray(counter) = Array(nameCell.Value, nameCell.Offset(0, 4).Value)
counter = counter + 1
' Stamp action log
nameCell.Offset(0, 5).Value = "Sent"
nameCell.Offset(0, 6).Value = Environ$("username")
nameCell.Offset(0, 7).Value = "E-mail sent on: " & Now()
' To be able to check later
anyExpiring = True
End If
Next nameCell
' Exit if there are not expiring contacts
If Not anyExpiring Then
MsgBox "There are not expiring contacts"
Exit Sub
End If
' Prepare message
Dim namesList As String
For counter = 0 To UBound(infoArray)
namesList = namesList & infoArray(counter)(0) & vbTab & vbTab & " | " & vbTab & vbTab & infoArray(counter)(1) & vbNewLine
Next counter
Dim emailBodyTemplate As String
emailBodyTemplate = "This is an automated e-mail to let you know that the following CTC will expire as follow:" & vbCrLf & vbCrLf & _
"Name" & vbTab & vbTab & vbTab & " | " & vbTab & vbTab & vbTab & " CTC Expiry date" & vbCrLf & _
"<namesList>" & vbCrLf & vbCrLf & _
"Many Thanks " & vbCrLf & _
vbCrLf & "Kind Regards" & vbCrLf & vbCrLf & Environ("username")
Dim emailBody As String
emailBody = Replace(emailBodyTemplate, "<namesList>", namesList)
' Start outlook (late bound)
Dim outApp As Object
On Error Resume Next
Set outApp = GetObject("Outlook.Applicatin")
On Error GoTo 0
' If outlook is not running, start an instance
If outApp Is Nothing Then Set outApp = CreateObject("Outlook.Application")
Do: Loop Until Not outApp Is Nothing
' Compose email
Dim outMail As Object
Set outMail = outApp.CreateItem(0)
With outMail
.To = "Sent to"
.CC = ""
.BCC = ""
.Subject = "CTC will expire soon"
.ReadReceiptRequested = False
.Body = emailBody
.Display
End With
' Display message to user
Dim staffMessage As String
staffMessage = ("Email has been sent for below staff")
MsgBox staffMessage
' Clean up
Set outApp = Nothing
Set outMail = Nothing
End Sub
Let me know if it works
Very new to VBA and trying to create an automated textfile export.
Currently it works like a charm for row 1 and the textfile is created. But when adding data on row 2 as well I get:
Runtime error 91, Object variable or With block variable not set.
Any help would be much appreciated!
Sub Exportera()
Dim bKlar As Boolean
Dim bSkrivPSlut As Boolean
Dim bSkrivPStart As Boolean
Dim fsoExpFil As FileSystemObject
Dim fsoTextStream2 As TextStream
Dim sExportFile As String
Dim iSvar As Integer
Dim iSvar2 As Integer
Dim sSokvag As String
Dim sFilnamn As String
Dim sTemp As String
Dim sPFalt As String
Dim cVarde As Currency
Dim sDatum As String
'alright då skapar vi fil och skriver till den
Set fsoExpFil = New FileSystemObject
Range("K10").Select
sSokvag = Trim(ActiveCell.FormulaR1C1)
Range("K13").Select
sFilnamn = Trim(ActiveCell.FormulaR1C1)
If Not UCase(Right(sFilnamn, 4)) = ".TXT" Then
sFilnamn = sFilnamn & ".txt"
End If
sExportFile = sSokvag & "\" & sFilnamn
If sSokvag = "" Or sFilnamn = "" Then
MsgBox "Exporten avbryts då sökväg och filnamn saknas för exportfilen.", vbInformation, sAppName
Exit Sub
Else
If fsoExpFil.FileExists(sExportFile) = True Then
iSvar = MsgBox("Filen " & sFilnamn & " finns redan, skall den ersättas?", vbYesNo, sAppName)
If iSvar = vbNo Then
Exit Sub
End If
Else
iSvar = MsgBox("Är du säker att du vill exportera?", vbYesNo, "Exportera")
End If
End If
If iSvar = vbYes Then
Set fsoTextStream2 = fsoExpFil.OpenTextFile(sExportFile, ForWriting, True)
fsoTextStream2.WriteLine "Filhuvud"
fsoTextStream2.WriteLine vbTab & "Typ=" & """Anställda"""
sTemp = "SkapadAv=" & """"
sTemp = sTemp & "Importfil"
sTemp = sTemp & """"
fsoTextStream2.WriteLine vbTab & sTemp
fsoTextStream2.WriteLine vbTab & "DatumTid=" & "#" & Now & "#"
bKlar = False
i = 1
Sheets("Data").Select
While bKlar = False
i = i + 1
Range("A" & i).Select
If Trim(ActiveCell.FormulaR1C1) <> "" Then
If IsNumeric(ActiveCell.FormulaR1C1) Then
fsoTextStream2.WriteLine "PStart"
fsoTextStream2.WriteLine " Typ = ""Anställda"""
Range("A" & i).Select
If Trim(ActiveCell.FormulaR1C1) <> "" Then
fsoTextStream2.WriteLine " Anställningsnummer = " & ActiveCell.FormulaR1C1
End If
Range("B" & i).Select
If Trim(ActiveCell.Text) <> "" Then
fsoTextStream2.WriteLine " Namn=" & Trim(ActiveCell.FormulaR1C1)
End If
Range("D" & i).Select
If Trim(ActiveCell.Text) <> "" Then
fsoTextStream2.WriteLine " Utdelningsadress=" & ActiveCell.FormulaR1C1
End If
Range("E" & i).Select
If Trim(ActiveCell.Text) <> "" Then
fsoTextStream2.WriteLine " co_adress=" & ActiveCell.FormulaR1C1
End If
Range("G" & i).Select
If Trim(ActiveCell.Text) <> "" Then
fsoTextStream2.WriteLine " Postadress=" & ActiveCell.FormulaR1C1
End If
Range("F" & i).Select
If Trim(ActiveCell.Text) <> "" Then
fsoTextStream2.WriteLine " Postnummer=" & ActiveCell.FormulaR1C1
End If
Range("C" & i).Select
If Trim(ActiveCell.Text) <> "" Then
sTemp = ActiveCell.FormulaR1C1
sTemp = Mid(sTemp, 1, 6) & "-" & Mid(sTemp, 7)
fsoTextStream2.WriteLine " Personnummer=" & sTemp
End If
Range("H" & i).Select
If Trim(ActiveCell.Text) <> "" Then
fsoTextStream2.WriteLine " E_mail=" & ActiveCell.FormulaR1C1
End If
Range("I" & i).Select
If Trim(ActiveCell.Text) <> "" Then
sTemp = ActiveCell.FormulaR1C1
Range("AM" & i).Select
sTemp = sTemp & ActiveCell.FormulaR1C1
sTemp = Replace(sTemp, "-", "")
fsoTextStream2.WriteLine " Bankkontonummer=" & sTemp
End If
Range("J" & i).Select
If Trim(ActiveCell.Text) <> "" Then
sDatum = ActiveCell.Text
fsoTextStream2.WriteLine " Anställningsdatum=" & "#" & sDatum & "#"
End If
fsoTextStream2.WriteLine "PSlut"
fsoTextStream2.Close
MsgBox "Exporten är klar", vbInformation, sAppName
End If
Else
bKlar = True
End If
Wend
End If
End Sub
Your problem is not exactly what you'd be expecting.
Note that in your while loop, you close your filestream object at the end with fsoTextStream2.Close. What you'll be seeing is that it will successfully write the first line, but then close the file and then try to write to a file that is closed.
Simply moving this outside the loop (after wend) will fix your problem (Shown below).
fsoTextStream2.WriteLine "PSlut"
MsgBox "Exporten är klar", vbInformation, sAppName
End If
Else
bKlar = True
End If
Wend
fsoTextStream2.Close 'This line has been moved outside the loop
End If
End Sub
There's quite a few improvements for your code, if you alter it slightly to avoid .select calls. Also .value rather than .text might be useful if your cells have numeric input. Note that you can extract cell values without having them selected by using range("A" & i).value (or simply range("A" & i)) using worksheet("sheetname").range("A" & i) to access specific sheet cells. (cells(row, column) works just as well).
I have a code in Excel that works great when the form is used by one person at a time. As soon as this form is open on multiple machines on the network, it gives an error msg.
The Error Msg reads:
Run-time error '1004':
Document not saved. The document may be open, or an error may have encountered when saving.
When clicking on Debug, it highlights the following line:
ws.ExportAsFixedFormat 0, FileName
Private Sub CommandButton1_Click()
Dim d As Date
Dim m As String
Dim dy As String
Dim yr As String
Dim FileName As String
Dim a1 As String
Dim b1 As String
Dim ws As Worksheet
Dim dr As String
dr = "G:\Operations\Expedite Requests"
Set ws = Sheets("Sheet1")
myarr = Array("Date", "Customer", "PO#", "Workorder#", "Part Number", "Requested Due Date", _
"Original Promise Date", "Special Note(s)", "Material Substitutions", "Requested By")
j = 0
With ws
A5 = .Range("A5").Value
A9 = .Range("A9").Value
For i = 3 To 21 Step 2
If .Cells(i, 1).Value = "" Then
msg = msg & myarr(j) & vbLf
End If
j = j + 1
Next
If msg <> vbNullString Then
If MsgBox("Form is not complete. Do you want to continue?" & vbLf & _
"(Please Type N/A If The Information is not Avalaible)" & vbLf & "Following information is missing:" & vbLf & msg, vbQuestion + vbYesNo) <> vbYes Then
Exit Sub
End If
End If
End With
Set ws = Sheets("Expedite Form")
d = Date
m = Month(d)
dy = Day(d)
yr = Year(d)
FileName = dr & "\" & yr & "-" & m & "-" & dy & " " & A5 & A9
ws.ExportAsFixedFormat 0, FileName
With CreateObject("Outlook.Application").CreateItem(0)
Dim cell As Range
Dim strBody As String
For Each cell In ThisWorkbook.Sheets("Sheet1").Range("A1:A21")
strBody = strBody & cell.Value & vbNewLine
Next
.To = "TEST1#TEST1.com"
.CC = "TEST2#TEST2.com;
.BCC = "TEST3#TEST3.com"
.Subject = "Expedite Request"
.Body = strBody
.attachments.Add dr & "\" & yr & "-" & m & "-" & dy & " " & A5 & A9 & ".pdf"
.Send 'use .Display to display email; use .send to send email
MsgBox ("Email Sent To Operations Team")
End With
Call resetForm
End Sub
Sub resetForm()
Worksheets("Sheet1").Range("A5").Value = ""
Worksheets("Sheet1").Range("A7").Value = ""
Worksheets("Sheet1").Range("A9").Value = ""
Worksheets("Sheet1").Range("A11").Value = ""
Worksheets("Sheet1").Range("A13").Value = ""
Worksheets("Sheet1").Range("A15").Value = ""
Worksheets("Sheet1").Range("A17").Value = ""
Worksheets("Sheet1").Range("A19").Value = ""
Worksheets("Sheet1").Range("A21").Value = ""
End Sub
I have used hyperlinks.add several times now and never had any problems with it.
Now I added a line of code: SourceBook.Sheets(ESN & "_SV" & SV).Hyperlinks.Add Anchor:=Range("A" & i), _
Address:=ToPath & NewName to my base code (which you can find under here). This should add a link to the newly created document.
The problem is that excel always says it cannot open the file. The link I enter via code is right, as I copied it with debug.print and it opened the file without a problem.
It came to my attention that the hyperlink I added was modified by excel when I hold my mouse over the hyperlink. I wonder how this is possible.
A second problem I encounterd is that when I enter the hyperlink manually and navigate manually to the file to make sure it takes the right file, excel still modifies my link and says "cannot open specified file".
Anyone an idea what might go wrong here? Thanks!
Code:
`Application.ScreenUpdating = False
Dim i, j, FSO As Object, SV, ESN, PartName, ToPath, FromPath, NewName, MsgBoxAnswer, TargetBook As Workbook, SourceBook As Workbook
Dim OS, PN, SN, ProjectNumber, Customer, StartDate, EndDate, LastRowCMM
ESN = ActiveWorkbook.ActiveSheet.Range("G2").Value
SV = ActiveWorkbook.ActiveSheet.Range("K2").Value
ProjectNumber = ActiveWorkbook.ActiveSheet.Range("A3").Value
Customer = ActiveWorkbook.ActiveSheet.Range("G3").Value
Set FSO = CreateObject("scripting.filesystemobject")
PGB.Min = 0
PGB.Value = 0
PGB.Max = 22
'Create main folder
If SV <> 1 Then
SV = "(SV " & SV & ")"
ToPath = "U:\tmo\vanmolle\fiches constat\Fiches constats #" & ESN & " " & SV
Else
ToPath = "U:\tmo\vanmolle\fiches constat\Fiches constats #" & ESN
End If
If FSO.folderexists(ToPath) = True Then
MsgBoxAnswer = MsgBox("Folder already created.", vbExclamation, "Folder exists.")
Exit Sub
End If
FSO.createfolder (ToPath)
'Create all Excel files & fill them in
For i = 6 To 27
FromPath = "U:\tmo\VANMOLLE\Fiches constat\Template fiches constat LEAP.xlsm"
If SV <> 1 Then
ToPath = "U:\tmo\vanmolle\fiches constat\Fiches constats #" & ESN & " " & SV & "\"
Else
ToPath = "U:\tmo\vanmolle\fiches constat\Fiches constats #" & ESN & "\"
End If
FSO.copyfile Source:=FromPath, Destination:=ToPath
NewName = "#" & ESN & "_" & ActiveWorkbook.ActiveSheet.Range("A" & i) & ".xlsm"
If SV <> 1 Then
FromPath = "U:\tmo\vanmolle\fiches constat\Fiches constats #" & ESN & " " & SV & "\Template fiches constat LEAP.xlsm"
Else
FromPath = "U:\tmo\vanmolle\fiches constat\Fiches constats #" & ESN & "\Template fiches constat LEAP.xlsm"
End If
Name FromPath As ToPath & NewName
Set SourceBook = ThisWorkbook
Set TargetBook = Workbooks.Open(ToPath & NewName)
TargetBook.Sheets("Sheet1").Activate
PartName = SourceBook.ActiveSheet.Range("A" & i).Value
OS = SourceBook.ActiveSheet.Range("D" & i).Value
PN = SourceBook.ActiveSheet.Range("B" & i).Value
SN = SourceBook.ActiveSheet.Range("C" & i).Value
If SN = "" Then SN = "N/A"
StartDate = SourceBook.ActiveSheet.Range("G" & i).Value
EndDate = SourceBook.ActiveSheet.Range("H" & i).Value
'check for right CMM
'LastRowCMM = TargetBook.Sheets("Révision CMM").Range("B6").End(xlDown).Row
'For j = 1 To LastRowCMM
'If PartName = TargetBook.Sheets("Révision CMM").Range("A" & j).Value Then ActiveWorkbook.ActiveSheet.Range("A23").Value = ActiveWorkbook.Sheets("Révision CMM").Range("B" & j).Value
'Next j
TargetBook.ActiveSheet.Range("B9").Value = PartName
TargetBook.ActiveSheet.Range("B10").Value = OS
TargetBook.ActiveSheet.Range("B11").Value = "# " & ESN
TargetBook.ActiveSheet.Range("B12").Value = PN
TargetBook.ActiveSheet.Range("B13").Value = SN
TargetBook.ActiveSheet.Range("E9").Value = StartDate
TargetBook.ActiveSheet.Range("E10").Value = EndDate
TargetBook.ActiveSheet.Range("B14").Value = ProjectNumber
TargetBook.ActiveSheet.Range("B15").Value = Customer
TargetBook.ActiveSheet.PageSetup.PrintArea = "$A$1:$E$39"
TargetBook.Close True
'Add hyperlink
SourceBook.Sheets(ESN & "_SV" & SV).Hyperlinks.Add Anchor:=Range("A" & i), _
Address:=ToPath & NewName
Application.Wait (Now + TimeValue("00:00:01"))
Progress.PGB.Value = i - 5
Progress.Lbl.Caption = "File " & i - 5 & " of 22 copied."
Next i
Application.ScreenUpdating = True`
First thing first - declare each variable explicitly. E.g.:
Dim i as Long, j as Long, FSO As Object, SV as String, ESN as String and etc.
The way in your code - Dim i, j, SV, ESN, PartName, ToPath they are declared as variant.
Second thing second - try something really very small to debug further. E.g. write this small piece:
Sub TestMe()
With Worksheets(1)
.Hyperlinks.Add anchor:=.Range("A1"), Address:="C:\Users\UserName\Desktop\test.docx"
End With
End Sub
and check whether it works. If it doesn't, debug further, check whether cells are locked or anything similar.
The title sums this one up.
Basically I would like to download all files that have been modified in a specific range of times so I am in need of a way to get the last modified date of a file in Office365/SharePoint.
Sub TestWhen()
SPFilePath = "http://teams.MyCompany.com/sites/PATH/PATH/Fulfillment/Forms/AllItems.aspx"
Debug.Print SPLastModified(SPFilePath, "2021_MyFileName.xlsx")
End Sub
Function SPLastModified(SPUrl As String, SPFName As String)
Dim PagesHTML As String
Dim Dadate As String
Dim DaDateEnd As String
Dim arr() As String
arr = Split(OutString, " ")
Dim LastChange As Variant
Set ie = CreateObject("InternetExplorer.Application")
With ie
.Visible = True
.navigate SPUrl
Do Until .readyState = 4
DoEvents
Loop
Do While .busy: DoEvents: Loop
Do Until .readyState = 4
DoEvents
Loop
PagesHTML = ie.document.DocumentElement.outerHTML
End With
' Get to File
Dadate = InStr(PagesHTML, "FileLeafRef" & Chr(34) & ": " & Chr(34) & SPFName)
' Get to Modified Date
ModifiedText = "Modified" & Chr(34) & ": "
Dadate = Dadate + InStr(Mid(PagesHTML, Dadate), ModifiedText)
OutString = Mid(PagesHTML, Dadate + Len(ModifiedText), 27)
arr = Split(OutString, " ")
LastChange = arr(1) & " " & arr(2)
LastChange = arr(0) & "/" & Mid(arr(1), 6) & "/" & Mid(arr(2), 6, 4) & " " & LastChange
SPLastModified = LastChange
End Function
To my knowledge there is no way change the date modified. One way would to do, would be to put a workflow and him have a break to the desired date and edit any column, but the modified person would also be changed.