我在这个问题上看到了很多问题，但没有一个解决方案适合我的情况（我认为），所以任何帮助都表示赞赏。设置 LR 整数变量的值时收到错误。与许多其他人一样，只有第二次运行子程序才会失败。
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
我是VBA的新手，所以请注意任何多余的或只是简单的愚蠢编码方法。
子程序在第一次运行时完美运行，而不是第二次运行。请帮忙。
谢谢。