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
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"
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.
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.
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.