VBA从单元格更改
为了解释我的标题，基本上我有一个macros的代码，显示在秒内的请求天数，需要它从我们的共享邮箱中导出。 现在每天都要改变我们需要出口的天数，并且变得非常令人沮丧。 以下行是有问题的：
If VBA.DateValue(VBA.Now) - VBA.DateValue(vItem.ReceivedTime) <= 10 Then 这个数字10需要每天更改，所以我尝试使用活动单元格，但没有成功，因为我得到一个运行时错误438。
所以我的问题是：是否有一种方法，在一个分开的电子表格中input我需要导出的天数，那条线可以从那里获取信息并继续执行代码？
请参阅下面的完整代码。
Sub Accomplished() Application.Run "Module5.OptimizeCode_Begin" Dim Folder As Outlook.MAPIFolder Dim sFolders As Outlook.MAPIFolder Dim iRow As Integer, oRow As Integer Dim MailBoxName As String, Pst_Folder_Name As String Dim vItems As Outlook.Items Dim vItem As Object 'Mailbox or PST Main Folder Name (As how it is displayed in your Outlook Session) MailBoxName = "Castle Donington Time and Attendance" 'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session) Pst_Folder_Name = "Accomplished" 'Sample "Inbox" or "Sent Items" 'To directly a Folder at a high level 'Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name) 'To access a main folder or a subfolder (level-1) For Each Folder In Outlook.Session.Folders(MailBoxName).Folders If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found For Each sFolders In Folder.Folders If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then Set Folder = sFolders GoTo Label_Folder_Found End If Next sFolders Next Folder Label_Folder_Found: If Folder.Name = "" Then MsgBox "Invalid Data in Input" GoTo End_Lbl1: End If 'Read Through each Mail and export the details to Excel for Email Archival ThisWorkbook.Sheets(3).Activate Folder.Items.sort "Received" 'Insert Column Headers ThisWorkbook.Sheets(3).Cells(1, 1) = "Sender" ThisWorkbook.Sheets(3).Cells(1, 2) = "Subject" ThisWorkbook.Sheets(3).Cells(1, 3) = "Date" ThisWorkbook.Sheets(3).Cells(1, 4) = "Sent" ThisWorkbook.Sheets(3).Cells(1, 5) = "EmailID" ThisWorkbook.Sheets(3).Cells(1, 6) = "Categories" ThisWorkbook.Sheets(3).Cells(1, 7) = "Parent" 'ThisWorkbook.Sheets(1).Cells(1, 6) = "Body" 'Export eMail Data from PST Folder oRow = 1 Set vItems = Folder.Items For iRow = 1 To vItems.Count Set vItem = vItems.Item(iRow) If vItem.Class = 43 Then 'If condition to import mails received in last 60 days 'To import all emails, comment or remove this IF condition If VBA.DateValue(VBA.Now) - VBA.DateValue(vItem.ReceivedTime) <= 10 Then oRow = oRow + 1 ThisWorkbook.Sheets(3).Cells(oRow, 1).Select ThisWorkbook.Sheets(3).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName ThisWorkbook.Sheets(3).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject ThisWorkbook.Sheets(3).Cells(oRow, 3) = Folder.Items.Item(iRow).ReceivedTime ThisWorkbook.Sheets(3).Cells(oRow, 4) = Folder.Items.Item(iRow).SentOn ThisWorkbook.Sheets(3).Cells(oRow, 5) = Folder.Items.Item(iRow).ConversationID ThisWorkbook.Sheets(3).Cells(oRow, 6) = Folder.Items.Item(iRow).Categories ThisWorkbook.Sheets(3).Cells(oRow, 7) = Folder.Items.Item(iRow).Parent 'ThisWorkbook.Sheets(3).Cells(oRow, 8) = Folder.Items.Item(iRow).Sent 'ThisWorkbook.Sheets(1).Cells(oRow, 6) = Folder.Items.Item(iRow).Body End If End If Next iRow MsgBox "Extration Complete ^.^" Set Folder = Nothing Set sFolders = Nothing ' sheet3_copypaste Macro Sheets("Sheet3").Select ActiveWindow.SmallScroll Down:=-33 Range("A2:H3001").Select Application.CutCopyMode = False Selection.Copy Sheets("Full List").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Format Sheets("Full List").Select Columns("D:E").Select Selection.NumberFormat = "m/d/yyyy h:mm" Range("D1").Select ' sort Macro Range("D6").Select ActiveWorkbook.Worksheets("Full List").sort.SortFields.Clear ActiveWorkbook.Worksheets("Full List").sort.SortFields.Add Key:=Range("D6"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Full List").sort .SetRange Range("A5:I4976") .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Range("D1").Select End_Lbl1: Application.Run "Module5.OptimizeCode_End" End Sub
感谢您的关注。 任何问题，我很高兴回答
为了与Excel和macros保持一致， 工作簿是一个完整的xlsm文件，其中包含一组工作表 （您将数据放在单独的选项卡上）。 通过一个分离的电子表格，我假设一个不同的工作簿。
以下是从电子表格获取数据的一些有用的代码。
主函数GetData在底部，而不是将数据存储在本地单元格中，您只需将其放入一个variables中，然后在“<”语句中使用它。
Sub GetDataDemo() Dim FilePath$, Row&, Column&, Address$ 'change constants & FilePath below to suit '*************************************** Const FileName$ = "Book1.xls" Const SheetName$ = "Sheet1" Const NumRows& = 10 Const NumColumns& = 10 FilePath = ActiveWorkbook.Path & "\" '*************************************** DoEvents Application.ScreenUpdating = False If Dir(FilePath & FileName) = Empty Then MsgBox "The file " & FileName & " was not found", , "File Doesn't Exist" Exit Sub End If For Row = 1 To NumRows For Column = 1 To NumColumns Address = Cells(Row, Column).Address Cells(Row, Column) = GetData(FilePath, FileName, SheetName, Address) Columns.AutoFit Next Column Next Row ActiveWindow.DisplayZeros = False End Sub Private Function GetData(Path, File, Sheet, Address) Dim Data$ Data = "'" & Path & "[" & File & "]" & Sheet & "'!" & _ Range(Address).Range("A1").Address(, , xlR1C1) GetData = ExecuteExcel4Macro(Data) End Function
如果它来自同一个工作簿，你只需要使用类似的东西
dim NUMDAYS as double NUMDAYS = sheets("sheet2").range("A1").value to assign to a variable which would be used later in your macro. If VBA.DateValue(VBA.Now) - VBA.DateValue(vItem.ReceivedTime) <= NUMDAYS Then