Getting file last modified date (explorer value not cmd value) - vba

I have written some Excel VBA code to add the filenames, versions, and last modified date/time to a worksheet. The code appears to work fine, except sometimes the time portion of the Last Modified Date for a file will either be exactly 1 hour forward or backward from what I see in an Explorer window.
I have noticed the values that my code returns is the same as the modified date/time shown in a cmd window if I perform a dir command.
For example, if I look up the dbghelp.dll file in the system32 folder:
C:\Windows\System32>dir dbghelp.*
Volume in drive C has no label.
Volume Serial Number is 16E8-4159
Directory of C:\Windows\System32
21/11/2010 04:24 1,087,488 dbghelp.dll
1 File(s) 1,087,488 bytes
0 Dir(s) 60,439,101,440 bytes free
C:\Windows\System32>
But the same file in an Explorer window shows a modified time of 03:24 on 21/11/2010 - 1 hour earlier.
The code I have written is returning the cmd window time, whereas I want the Explorer window time:
Sub GetFileDetails()
Dim path As String
Dim objFSO As Object
Dim objFile As Object
Dim objFolder As Object
Dim loopCount As Integer
Dim pathCheck As Boolean
'Prompt for directory path
path = InputBox(Prompt:="Enter file path", Title:="Enter file path", Default:="")
If (path = "" Or path = vbNullString) Then
MsgBox ("Invalid path - exiting")
Exit Sub
End If
'Required for interacting with filesystem
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(path)
'1st row for path title, 2nd row for column headings
loopCount = 3
For Each objFile In objFolder.Files
Range("A" & loopCount).Value = objFile.Name
Range("B" & loopCount).Value = objFSO.GetFileVersion(objFile)
Range("C" & loopCount).Value = objFile.DateLastModified
'Combine Version and Modified
If Range("B" & loopCount).Value <> "" Then
Range("D" & loopCount).Value = Range("B" & loopCount).Value & ", " & Range("C" & loopCount).Value
Else
Range("D" & loopCount).Value = Range("C" & loopCount).Value
End If
loopCount = loopCount + 1
Next
'Set up headings
Range("A" & 1).Value = (loopCount - 3) & " files found in " & path
Range("A" & 2).Value = "FileName"
Range("B" & 2).Value = "Version"
Range("C" & 2).Value = "Modified"
Range("D" & 2).Value = "Version & Modified"
End Sub
If anyone can shed some light on this issue - it will be greatly appreciated.
===EDIT===
This is the code I have come up with which always gives me the same time as displayed in an explorer window:
Sub GetFileDetails()
Dim path As String
Dim objFSO As Object
Dim objFile As Object
Dim objFolder As Object
Dim loopCount As Integer
Dim pathCheck As Boolean
Dim modDate As Date
Dim modHour As Integer
Dim modMin As Integer
'Prompt for directory path
path = InputBox(Prompt:="Enter file path", Title:="Enter file path", Default:="")
If (path = "" Or path = vbNullString) Then
MsgBox ("Invalid path - exiting")
Exit Sub
End If
'Required for interacting with filesystem
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(path)
'1st row for path title, 2nd row for column headings
loopCount = 3
For Each objFile In objFolder.Files
Range("A" & loopCount).Value = objFile.Name
Range("B" & loopCount).Value = objFSO.GetFileVersion(objFile)
Range("D" & loopCount).Value = objFile.Name
'The date modified time for files made in Summer Time are correct, whereas Winter Time will be 1 hour forward
If (IsItSummerTime(objFile.DateLastModified) = True) Then
Range("C" & loopCount).Value = objFile.DateLastModified
Else
modDate = Format(objFile.DateLastModified, "DD-MM-YYYY")
modHour = Hour(objFile.DateLastModified)
modMin = Minute(objFile.DateLastModified)
modHour = modHour - 1
If (modHour < 10) Then
If (modMin < 10) Then
Range("C" & loopCount).Value = modDate & " 0" & modHour & ":0" & modMin
Else
Range("C" & loopCount).Value = modDate & " 0" & modHour & ":" & modMin
End If
Else
If (modMin < 10) Then
Range("C" & loopCount).Value = modDate & " " & modHour & ":0" & modMin
Else
Range("C" & loopCount).Value = modDate & " " & modHour & ":" & modMin
End If
End If
End If
'Combine Version and Modified
If Range("B" & loopCount).Value <> "" Then
Range("E" & loopCount).Value = Range("B" & loopCount).Value & ", " & Range("C" & loopCount).Value
Else
Range("E" & loopCount).Value = Range("C" & loopCount).Value
End If
loopCount = loopCount + 1
Next
'Set up headings
Range("A" & 1).Value = (loopCount - 3) & " files found in " & path
Range("A" & 2).Value = "FileName"
Range("B" & 2).Value = "Version"
Range("C" & 2).Value = "Modified"
Range("D" & 2).Value = "FileName"
Range("E" & 2).Value = "Version & Modified"
End Sub
Function IsItSummerTime(inDate As Date) As Boolean
Dim inDateYear As Integer
Dim findFirstSunday As Date
Dim firstSundayDate As Date
Dim startDays As Integer
Dim endDays As Integer
Dim summerStart As Date
Dim summerEnd As Date
'Summer Time starts on the 13th week
'Summer Time ends on the 42nd week
If (IsItALeapYear(inDate) = True) Then
startDays = (12 * 7) + 1
endDays = (42 * 7) + 1
Else
startDays = 12 * 7
endDays = 42 * 7
End If
'Find the date of the first Sunday in the year
inDateYear = Year(inDate)
For i = 1 To 7
findFirstSunday = DateSerial(inDateYear, 1, i)
If (Weekday(findFirstSunday) = 1) Then
firstSundayDate = findFirstSunday
End If
Next i
'Calculate the start and end dates for Summer Time
summerStart = firstSundayDate + startDays
summerEnd = firstSundayDate + endDays
'Compare inDate to Summer Time values and return boolean value
If (inDate >= summerStart And inDate < summerEnd) Then
IsItSummerTime = True
Else
IsItSummerTime = False
End If
End Function
Function IsItALeapYear(inDate As Date) As Boolean
If (Month(DateSerial(Year(inDate), 2, 29))) = 2 Then
IsItALeapYear = True
Else
IsItALeapYear = False
End If
End Function

It looks like this is ultimately an OS issue that you'd have to work around, like has been shown, especially since you've edited your code to account for DST.
But you could also use the FileDateTime function. The help article for this points out that the result of this function is based on your system's locale settings. The help article for the DateLastModified property doesn't provide any such caveats, at least for Excel online help.
To modify an exerpt from your edited code above:
'1st row for path title, 2nd row for column headings
loopCount = 3
For Each objFile In objFolder.Files
Range("A" & loopCount).Value = objFile.Name
'use the full path name
Range("B" & loopCount).Value = FileDateTime(objFile_fullpathname)
Range("D" & loopCount).Value = objFile.Name

Related

Get data type from closed workbook cell and vary action accordingly

I'm collecting metric values from many different worksheets in one overview sheet which will be used for generating a PowerBI dashboard.
Below is my code, i'm new to vba so it's probably not so elegant, but works for what i need, except for one thing.
Some of the metric values in these sheets are integers, others have data type percentage.
If the value in the metric sheet has number format %, for example "10" formatted as %, it gets taken as 0,1 with the current code i have. I would like to multiply these percentages with 100 and add this number in the overview sheet. But I have difficulties finding out how i can extract the data type and if a percentage, multiply with 100, and if no percentage, get the value as is. Would anyone be able to help with that?
Many thanks in advance -
Function HasSheet(fPath As String, fName As String, sheetName As String)
On Error Resume Next
Dim f As String
f = "'" & fPath & "[" & fName & "]" & sheetName & "'!R1C1"
HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
If Err.Number <> 0 Then
HasSheet = False
End If
On Error GoTo 0
End Function
Sub CollectMetrics()
Dim id As Integer
Dim Ind As String
Dim MetricName As String
Dim Include1 As String
Dim Include2 As String
Dim Segment As String
Dim file As String
Dim filepath As String
Dim filename As String
Dim s As Boolean
Dim D As Date
Dim MonthNbr As Integer
Set sh1 = Worksheets("Metrics")
Set sh2 = Worksheets("Metadata")
NumRows = sh1.Range("A1", sh1.Range("A1").End(xlDown)).Rows.Count
For id = 2 To NumRows
MetricName = sh1.Range("A" & id).Value
Include1 = Application.WorksheetFunction.VLookup(MetricName, sh2.Range("B2:L100"), 9, True)
Include2 = Application.WorksheetFunction.VLookup(MetricName, sh2.Range("B2:L100"), 10, True)
Ind = Application.WorksheetFunction.VLookup(MetricName, sh2.Range("B2:L100"), 2, True)
filename = Ind & " " & MetricName & " 2018.xlsx"
If Include1 = "auto" And Include2 = "yes" Then
Segment = sh1.Range("B" & id).Value
file = "='https://xxx/[" & filename & "]" & Segment
filepath = "https://xxx/"
s = HasSheet(filepath, filename, Segment)
If s Then
D = sh1.Range("C" & id).Value
MonthNbr = Month(D)
sh1.Range("D" & id).Value = file & "'!D" & (MonthNbr + 13)
sh1.Range("E" & id).Value = file & "'!E" & (MonthNbr + 13)
sh1.Range("F" & id).Value = file & "'!F" & (MonthNbr + 13)
sh1.Range("G" & id).Value = file & "'!G" & (MonthNbr + 13)
sh1.Range("J" & id).Value = file & "'!D" & (MonthNbr + 40)
sh1.Range("K" & id).Value = file & "'!E" & (MonthNbr + 40)
sh1.Range("L" & id).Value = file & "'!F" & (MonthNbr + 40)
sh1.Range("M" & id).Value = file & "'!G" & (MonthNbr + 40)
sh1.Range("O" & id).Value = "values updated on " & Format(Now(), "dd-mm-yy")
Else
sh1.Range("O" & id).Value = "sheet available but segment missing"
End If
ElseIf Include2 = "no" Then
sh1.Range("O" & id).Value = "metric set to not yet include"
ElseIf Include1 = "manual" Then
sh1.Range("O" & id).Value = "metric to be manually updated"
End If
Next
MsgBox (" Update completed! ")
End Sub
I would try to avoid multiplying a percentage by 100 and adding a percent symbol, if there's the option to do it the "right way".
It's not a huge problem in this case, it's just better to create good habits. (And just for the record, the reason 10% gets taken as 0,1 is because 10% is 0,1.
Nonetheless, we need an easy way to display it as a percentage instead of a fraction of 1 (when applicable), and as with many tasks in Excel, there are multiple ways to accomplish the same thing.
This way took me the least thought:
Range("B1") = Range("A1") 'copies the value
Range("B1").NumberFormat = Range("A1") .NumberFormat 'copies the number format.
Changes I made:
The "cleanest" way to do this was with a small sub called copyNumber and adjusting the affected lines to use the new procedure.
I tidied indentation - which is important for organization and readability.
I added Option Explicit which is a good idea to have at the beginning of every module, to help recognize oversights such as...
sh1 and sh2 were not declared as Worksheets, so I added Dim statements for them - but squished them onto a line shared with their Set statements with : colons.
The other changes I made were purely cosmetic and more of a matter of perference, and obviously if you don't like those changes, don't use them. :-)
I got rid of the ElseIf's - I don't like them for the same reason indentation is important.
I used With..End statements to remove repetitive code (like Sh1. and Application.WorksheetFunction.)
I squished the variable declaration (Dim statements) from "a page" into 3 lines.
Adjusted Code:
Option Explicit
Function HasSheet(fPath As String, fName As String, sheetName As String)
On Error Resume Next
Dim f As String
f = "'" & fPath & "[" & fName & "]" & sheetName & "'!R1C1"
HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
If Err Then HasSheet = False
On Error GoTo 0
End Function
Sub copyNumber(rgeSrc As Range, rgeDest As Range)
rgeDest.Value = rgeSrc.Value ' copy number
rgeDest.NumberFormat = rgeSrc.NumberFormat ' copy number format
End Sub
Sub CollectMetrics()
Dim MetricName As String, Segment As String, Ind As String, Include1 As String, Include2 As String
Dim file As String, filePath As String, fileName As String
Dim MonthNbr As Integer, id As Integer, numRows As Integer
Dim sh1 As Worksheet: Set sh1 = Worksheets("Metrics")
Dim sh2 As Worksheet: Set sh2 = Worksheets("Metadata")
With sh1
numRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
For id = 2 To numRows
MetricName = Range("A" & id)
With Application.WorksheetFunction
Include1 = .VLookup(MetricName, sh2.Range("B2:L100"), 9, True)
Include2 = .VLookup(MetricName, sh2.Range("B2:L100"), 10, True)
Ind = .VLookup(MetricName, sh2.Range("B2:L100"), 2, True)
End With
fileName = Ind & " " & MetricName & " 2018.xlsx"
If Include1 = "auto" And Include2 = "yes" Then
Segment = Range("B" & id)
file = "='https://xxx/[" & fileName & "]" & Segment
filePath = "https://xxx/"
If HasSheet(filePath, fileName, Segment) Then
MonthNbr = Month(Range("C" & id))
copyNumber .Range("D" & id), Range(file & "'!D" & (MonthNbr + 13))
copyNumber .Range("E" & id), Range(file & "'!E" & (MonthNbr + 13))
copyNumber .Range("F" & id), Range(file & "'!F" & (MonthNbr + 13))
copyNumber .Range("G" & id), Range(file & "'!G" & (MonthNbr + 13))
copyNumber .Range("J" & id), Range(file & "'!D" & (MonthNbr + 40))
copyNumber .Range("K" & id), Range(file & "'!E" & (MonthNbr + 40))
copyNumber .Range("L" & id), Range(file & "'!F" & (MonthNbr + 40))
copyNumber .Range("M" & id), Range(file & "'!G" & (MonthNbr + 40))
Range("O" & id) = "Values updated on " & Format(Now(), "dd-mm-yy")
Else
Range("O" & id) = "Sheet available but segment missing"
End If
Else
If Include2 = "no" Then
Range("O" & id) = "Metric set to not yet include"
Else
If Include1 = "manual" Then Range("O" & id) = "Metric to be manually updated"
End If
End If
Next id
End With
MsgBox "Update completed!"
End Sub
Just in case someone is looking for this approach in future, here is the final code i used:
Option Explicit
Function HasSheet(fPath As String, fName As String, sheetName As String)
On Error Resume Next
Dim f As String
f = "'" & fPath & "[" & fName & "]" & sheetName & "'!R1C1"
HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
If Err Then HasSheet = False
On Error GoTo 0
End Function
Sub CollectMetrics()
Dim MetricName As String, Segment As String, Ind As String, Include1 As String, Include2 As String, Include3 As String
Dim file As String, filePath As String, fileName As String
Dim MonthNbr As Integer, id As Integer, numRows As Integer
Dim sh1 As Worksheet: Set sh1 = Worksheets("Metrics")
Dim sh2 As Worksheet: Set sh2 = Worksheets("Metadata")
With sh1
numRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
For id = 2 To numRows
MetricName = Range("A" & id)
With Application.WorksheetFunction
Include1 = .VLookup(MetricName, sh2.Range("B2:L100"), 9, True)
Include2 = .VLookup(MetricName, sh2.Range("B2:L100"), 10, True)
Include3 = .VLookup(MetricName, sh2.Range("B2:L100"), 11, True)
Ind = .VLookup(MetricName, sh2.Range("B2:L100"), 2, True)
End With
fileName = Ind & " " & MetricName & " 2018.xlsx"
If Include1 = "auto" And Include2 = "yes" Then
Segment = Range("B" & id)
file = "='https://xxxx/[" & fileName & "]" & Segment
filePath = "https://xxxx/"
If HasSheet(filePath, fileName, Segment) Then
MonthNbr = Month(Range("C" & id))
sh1.Range("D" & id).Value = file & "'!D" & (MonthNbr + 13)
sh1.Range("E" & id).Value = file & "'!E" & (MonthNbr + 13)
sh1.Range("F" & id).Value = file & "'!F" & (MonthNbr + 13)
sh1.Range("G" & id).Value = file & "'!G" & (MonthNbr + 13)
sh1.Range("H" & id).Value = file & "'!B" & (MonthNbr + 13) 'Actuals KPI Index
Select Case sh1.Range("H" & id).Value
Case "R"
sh1.Range("H" & id).Value = "3"
Case "Y"
sh1.Range("H" & id).Value = "2"
Case "G"
sh1.Range("H" & id).Value = "1"
End Select
sh1.Range("I" & id).Value = file & "'!D" & (MonthNbr + 40)
sh1.Range("J" & id).Value = file & "'!E" & (MonthNbr + 40)
sh1.Range("K" & id).Value = file & "'!F" & (MonthNbr + 40)
sh1.Range("L" & id).Value = file & "'!G" & (MonthNbr + 40)
sh1.Range("M" & id).Value = file & "'!B" & (MonthNbr + 13) 'YTD KPI Index
Select Case sh1.Range("M" & id).Value
Case "R"
sh1.Range("M" & id).Value = "3"
Case "Y"
sh1.Range("M" & id).Value = "2"
Case "G"
sh1.Range("M" & id).Value = "1"
End Select
Range("N" & id) = "Values updated on " & Format(Now(), "dd-mm-yy")
If Include3 = "%" Then ' multiply with 100 for percentages
sh1.Range("D" & id).Value = (sh1.Range("D" & id).Value) * 100
sh1.Range("E" & id).Value = (sh1.Range("E" & id).Value) * 100
sh1.Range("F" & id).Value = (sh1.Range("F" & id).Value) * 100
sh1.Range("G" & id).Value = (sh1.Range("G" & id).Value) * 100
sh1.Range("I" & id).Value = (sh1.Range("I" & id).Value) * 100
sh1.Range("J" & id).Value = (sh1.Range("J" & id).Value) * 100
sh1.Range("K" & id).Value = (sh1.Range("K" & id).Value) * 100
sh1.Range("L" & id).Value = (sh1.Range("L" & id).Value) * 100
End If
Else
Range("N" & id) = "Sheet available but segment missing"
End If
Else
If Include2 = "no" Then
Range("N" & id) = "Metric set to not yet include"
Else
If Include1 = "manual" Then Range("N" & id) = "Metric to be manually updated"
End If
End If
Next id
End With
MsgBox "Update completed!"
End Sub

Object does not support this property or method error

I'm trying to copy data from excel to fallible PDF form. with below code, I open fallible form and populate the data and I need to save using varibale 'pr' .
While saving it is throwing run time error
"Object doesn't support this property or method"
Dim fcount As Long
Dim sFieldName As String
Set AcrobatApplication = CreateObject("AcroExch.App")
Set AcrobatDocument = CreateObject("AcroExch.AVDoc")
If AcrobatDocument.Open("C:\Users\Desktop\Projects\Jan 2018\Excel to PDF\Test.pdf", "") Then
AcrobatApplication.Show
Set AcroForm = CreateObject("AFormAut.App")
Set Fields = AcroForm.Fields
fcount = Fields.Count ' Number of Fields
With ThisWorkbook.Sheets(1)
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
Fields("Enter county name").Value = Range("A" & i).Value
Fields("Enter county served").Value = Range("B" & i).Value
Fields("Parcel number").Value = Range("C" & i).Value
pr = Range("C" & i).Value
Fields("Property owner name").Value = Range("D" & i).Value
fname = "C:\Users\Desktop\Projects\Jan 2018\Excel to PDF\docs\" & pr & ".pdf"
If AcrobatDocument.Save(PDSaveFull, fname) = False Then
MsgBox ("Cannot save the modified document")
End If
Next
End With
Else
MsgBox "failure"
Dim pr as String
should be enough considering the fact that you are using it only here:
fname = "C:\Users\Desktop\Projects\Jan 2018\Excel to PDF\docs\" & pr & ".pdf"

Running VBA code written in Windows on a Mac

I've written some VBA to go through a folder and consolidate spreadsheets onto one masterfile. One of the first things I needed to do was to look for all files in a folder with the extension .xl*.
I wrote this on a Windows box, and now someone wants to run this on a Mac.
I have changes the line from
Fname = Dir(ThisWorkbook.Path & "/*.xl*")
to
Fname = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.xl*")
but I get a: run time error 68 - device not available error
How can I get this line running on a Mac?
For reference here is the complete code:
Sub Consolidation()
Application.ScreenUpdating = False
'find last record in mastersheet
Set destsheet = ThisWorkbook.Worksheets("Consolidated")
Set MyRange = Worksheets("Consolidated").Range("C" & "1")
lngLastRow = Cells(Rows.Count, MyRange.Column).End(xlUp).Row
'looks for files with the follwing extension
'Fname = Dir(ThisWorkbook.Path & "/*.xl*")
Fname = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.xl*")
'cycles through the folder
Do While Fname <> ""
If Fname <> ThisWorkbook.Name Then
Application.StatusBar = "Processing: " & Fname
Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
Set originsheet = wkbkorigin.Worksheets("Sheet1")
n = 0
m = 0
'adds recods to the next avaibale row
'destsheet.Range("B4").Offset(lngLastRow + 1, 1) = originsheet.Range("E4").Value
destsheet.Range("C" & lngLastRow + 1) = originsheet.Range("E4").Value
destsheet.Range("D" & lngLastRow + 1) = originsheet.Range("E5").Value
destsheet.Range("E" & lngLastRow + 1) = originsheet.Range("E6").Value
destsheet.Range("F" & lngLastRow + 1) = originsheet.Range("E7").Value
destsheet.Range("G" & lngLastRow + 1) = originsheet.Range("E8").Value
destsheet.Range("H" & lngLastRow + 1) = originsheet.Range("E9").Value
destsheet.Range("I" & lngLastRow + 1) = originsheet.Range("E10").Value
lngLastRow = lngLastRow + 1
wkbkorigin.Close SaveChanges:=False 'close current file
End If
'stips when out of files to import
Fname = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Try setting the Files and Folders permission on MacOS Security Preferences pane for Excel.

Copy data to new workbook and add specific text to each row´s value in a specific column

I am exporting data from one workbook to another workbook to T13:Tlastrow
This data, from column F in my workbook where I run this macro, I want to be put into {nyckel="TEXT HERE";} in column T in the "new" workbook, starting from row 13 (T13).
I am stuck here. So would really appreciate some help/solution. Thanks!
Sub CopyData()
Dim wkbCurrent As Workbook, wkbNew As Workbook
Set wkbCurrent = ActiveWorkbook
Dim valg, c, LastCell As Range
Set valg = Selection
Dim wkbPath, wkbFileName, lastrow As String
Dim LastRowInput As Long
Dim lrow, rwCount, lastrow2, LastRowInput2 As Long
Application.ScreenUpdating = False
' If nothing is selected in column A
If Selection.Columns(1).Column = 1 Then
wkbPath = ActiveWorkbook.Path & "\"
wkbFileName = Dir(wkbPath & "CIF LISTEN.xlsm")
Set wkbNew = Workbooks.Open(wkbPath & "CIF LISTEN.xlsm")
'Application.Run ("'C:\Users\niclas.madsen\Desktop\TEST\CIF LISTEN.xlsm'!DelLastRowData")
LastRowInput = Cells(Rows.count, "A").End(xlDown).Row
For Each c In valg.Cells
lrow = wkbNew.Worksheets(1).Range("B1").Offset(wkbNew.Worksheets(1).Rows.count - 1, 0).End(xlUp).Row + 1
lastrow2 = Range("A" & Rows.count).End(xlUp).Row
lastrow3 = Range("T" & Rows.count).End(xlUp).Row
wkbCurrent.ActiveSheet.Range("E" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("A" & lrow)
wkbCurrent.ActiveSheet.Range("A" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("B" & lrow)
wkbCurrent.ActiveSheet.Range("F" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("T" & lrow)
' Standard inputs
wkbNew.Worksheets(1).Range("D13:D" & lastrow2).Value = "Ange referens och period"
wkbNew.Worksheets(1).Range("E13:E" & lastrow2).Value = "99999002"
wkbNew.Worksheets(1).Range("G13:G" & lastrow2).Value = "EA"
wkbNew.Worksheets(1).Range("H13:H" & lastrow2).Value = "2"
wkbNew.Worksheets(1).Range("M13:M" & lastrow2).Value = "SEK"
wkbNew.Worksheets(1).Range("N13:N" & lastrow2).Value = "sv_SE"
wkbNew.Worksheets(1).Range("P13:P" & lastrow2).Value = "TRUE"
wkbNew.Worksheets(1).Range("Q13:Q" & lastrow2).Value = "TRUE"
wkbNew.Worksheets(1).Range("S13:S" & lastrow2).Value = "Catalog_extensions"
'wkbNew.Worksheets(1).Range("T" & lastrow3).Value = "{Nyckelord=" & wkbNew.Worksheets(1).Range("T" & lastrow3).Value & ";}"
Next
' Trying to get this to work
LastRowInput2 = wkbNew.Worksheets(1).Range("T" & wkbNew.Sheets("Sheet1").UsedRange.Rows.count + 1).End(xlUp).Row
For i = 0 To LastRowInput2 - 13
wkbNew.Worksheets(1).Range("T" & 13 + i).Value = "{Nyckelord=" & wkbNew.Worksheets(1).Range("T" & 13 + i).Value & ";}"
Next i
' END HERE
' wkbNew.Close False
' Find the number of rows that is copied over
wkbCurrent.ActiveSheet.Activate
areaCount = Selection.Areas.count
If areaCount <= 1 Then
MsgBox "The selection contains " & Selection.Rows.count & " suppliers."
' Write it in A10 in CIF LISTEN
wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & Selection.Rows.count & " Suppliers Added"
Else
i = 1
For Each A In Selection.Areas
'MsgBox "Area " & I & " of the selection contains " & _
a.Rows.count & " rows."
i = i + 1
rwCount = rwCount + A.Rows.count
Next A
MsgBox "The selection contains " & rwCount & " suppliers."
' Write it in A10 in CIF LISTEN
wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & rwCount & " Suppliers Added"
End If
wkbNew.Worksheets(1).Activate
Application.ScreenUpdating = True
Else
MsgBox "Please select cell(s) in column A", vbCritical, "Error"
Exit Sub
End If
End Sub
OK Try
wkbNew.Worksheets(1).Range("T" & lrow).Value = "{Nyckelord=" & wkbCurrent.ActiveSheet.Range("F" & c.Row).Value & "}"
Instead of your line:
wkbCurrent.ActiveSheet.Range("F" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("T" & lrow)
And remove the whole block marked 'Trying to get this to work
If the code is doing the right action but on the wrong cells, then the problem is in the start and end of the For loop. Your For Loop is going from row '13 + i' where i = 0 (so row 13), to row 13 + LastRowInput2 - 13 (so LastRowInput2). This seems right to me, so the problem must be with the value in LastRowInput2.
You need to correct this line:
LastRowInput2 = wkbNew.Worksheets(1).Range("T" & wkbNew.Sheets("Sheet1").UsedRange.Rows.count + 1).End(xlUp).Row
So that is gives you the correct last row input in your data. There are several approaches to finding the end of data depending on whether there may be blank cells in the middle and other factors. This may be one option:
LastRowInput2 = wkbNew.Worksheets(1).Range("T65000").End(xlUp).Row
Be sure to step through the code and verify that LastRowInput2 is set to the value you expect and then this should work.

Runtime Error 1004: Method 'Range' of object '_Global' failed

I've seen numerous questions on the issue but none of the solutions fit my situation (I think) so any help is appreciated. I receive the error when setting the value of the LR integer variable. As with many others having this issue, it only fails the second time the subroutine is run.
Sub SaveEmailAttachments()
' Creates each variable to be used
Dim xlApp As Excel.Application, xlWB As Excel.Workbook, xlAtt As Excel.Workbook
Dim olItem As Outlook.MailItem
Dim LR As Integer, NR As Integer, j As Integer, intDir As Integer, random As Integer
' Path to the HWB Master template to be used
Const strPath As String = "C:\Users\dkirksey\Documents\SOF\SOF Station HWB Master w Macro.xlsm"
' If no emails are selected, present an error and exit
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
' Creates a new Excel application
On Error Resume Next
Set xlApp = New Excel.Application
xlApp.Visible = False
'Opens the Excel workbook
On Error GoTo 0
Set xlWB = xlApp.Workbooks.Open(strPath)
'Creates a new directory to store today's information
intDir = (fIsFileDIR("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy"), vbDirectory))
If intDir = 0 Then
MkDir ("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy"))
MkDir ("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy") & "\HWBs")
'Process each selected email
For Each olItem In Application.ActiveExplorer.Selection
j = j + 1
For cnt = 1 To olItem.Attachments.Count
If Right(olItem.Attachments(1).FileName, 4) = "xlsx" Or Right(olItem.Attachments(1).FileName, 3) = "xls" Or Right(olItem.Attachments(1).FileName, 4) = "xlsm" Then
olItem.Attachments(cnt).SaveAsFile ("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy") & "\HWBs\" _
& Format(Now, "mmddyy") & " " & j & olItem.Attachments(cnt).DisplayName)
Set xlAtt = xlApp.Workbooks.Open("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy") & "\HWBs\" _
& Format(Now, "mmddyy") & " " & j & olItem.Attachments(cnt).DisplayName)
xlAtt.Activate
If xlAtt.ActiveSheet.Range("A3").Value = "HWB" And xlAtt.ActiveSheet.Range("B3").Value = "Instruction (optional)" And xlAtt.ActiveSheet.Range("C3").Value = "Route (optional)" Then
LR = xlAtt.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
xlAtt.ActiveSheet.Range("A4:C4" & LR).Select
Selection.Copy
xlWB.Activate
xlWB.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial xlPasteValues
xlWB.ActiveSheet.Cells(1, 1).Activate
End If
xlApp.DisplayAlerts = False
xlAtt.Close SaveChanges:=False
Else
olItem.Categories = "Purple Category"
End If
Next
Next olItem
j = 4
LR = xlWB.ActiveSheet.UsedRange.Rows.Count
Do Until j > LR
If IsNumeric(Cells(j, 1)) = False Then
Cells(j, 1).EntireRow.Delete
LR = LR - 1
ElseIf Cells(j, 1).Value = "" Then
Cells(j, 1).EntireRow.Delete
LR = LR - 1
Else
j = j + 1
End If
Loop
xlWB.SaveAs ("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy") & "\" & Format(Now, "mmddyy") & " Complete HWB List")
Else
ans = MsgBox("You have already run SOF today, would you like to continue anyway?", vbYesNo)
If ans = vbYes Then
random = Int((9999 - 100 + 1) * Rnd + 100)
MkDir ("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy") & random)
MkDir ("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy") & random & "\HWBs")
MsgBox "Your new folder is titled " & Format(Now, "mmddyy") & random & ", it is located in the Documents\SOF\HWB Files directory"
'Process each selected email
For Each olItem In Application.ActiveExplorer.Selection
j = j + 1
For cnt = 1 To olItem.Attachments.Count
If Right(olItem.Attachments(1).FileName, 4) = "xlsx" Or Right(olItem.Attachments(1).FileName, 3) = "xls" Or Right(olItem.Attachments(1).FileName, 4) = "xlsm" Then
olItem.Attachments(cnt).SaveAsFile ("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy") & random & "\HWBs\" _
& Format(Now, "mmddyy") & " " & j & olItem.Attachments(cnt).DisplayName)
Set xlAtt = xlApp.Workbooks.Open("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy") & random & "\HWBs\" _
& Format(Now, "mmddyy") & " " & j & olItem.Attachments(cnt).DisplayName)
xlAtt.Activate
If xlAtt.ActiveSheet.Range("A3").Value = "HWB" And xlAtt.ActiveSheet.Range("B3").Value = "Instruction (optional)" And xlAtt.ActiveSheet.Range("C3").Value = "Route (optional)" Then
LR = xlAtt.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
xlAtt.ActiveSheet.Range("A4:C4" & LR).Select
Selection.Copy
xlWB.Activate
xlWB.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial xlPasteValues
xlWB.ActiveSheet.Cells(1, 1).Activate
End If
xlApp.DisplayAlerts = False
xlAtt.Close SaveChanges:=False
Else
olItem.Categories = "Purple Category"
End If
Next
Next olItem
j = 4
LR = xlWB.ActiveSheet.UsedRange.Rows.Count
Do Until j > LR
If IsNumeric(Cells(j, 1)) = False Then
Cells(j, 1).EntireRow.Delete
LR = LR - 1
ElseIf Cells(j, 1).Value = "" Then
Cells(j, 1).EntireRow.Delete
LR = LR - 1
Else
j = j + 1
End If
Loop
xlWB.SaveAs ("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy") & random & "\" & Format(Now, "mmddyy") & " Complete HWB List")
Else
xlWB.Close
xlApp.DisplayAlerts = True
xlApp.Quit
Exit Sub
End If
End If
xlWB.Close
xlApp.DisplayAlerts = True
xlApp.Quit
MsgBox "Well played !"
End Sub
I'm a rookie with VBA so excuse any redundant or just plain idiotic coding methods you notice.
The subroutine works perfectly the first time it is run, just not the second. Please help.
Thank you.