VBA从单元格更改 [英] VBA changes from a cell

问题描述

为了解释我的标题，基本上我有一个宏代码，显示不正确的请求天数需要从共享邮箱导出。现在每天都要改变我们需要出口的天数，真的很沮丧。以下行有问题：

 如果VBA.DateValue（VBA.Now） -  VBA.DateValue（vItem.ReceivedTime）< ; = 10然后
  

这个数字需要每天更改，所以我尝试了活动单元格，没有成功，因为我收到运行时错误438。

所以我的问题是：有没有办法在一个分离的电子表格中输入我需要导出的天数，该行可以从那里获取信息并继续执行代码？

请参阅下面的完整代码。

$ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ b 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

'邮箱或PST主文件夹名称（如何显示在其中）您的Outlook会话）
MailBoxName =Castle Donington时间和出勤

'邮箱文件夹或PST文件夹名称（如何在Outlook会话中显示）
Pst_Folder_Name =完成'示例收件箱或已发送邮件

'直接在高级别的文件夹
'设置文件夹= Outlook.Session.Folders（MailBoxName）.Folders（Pst_Folder_Name）

'访问主文件夹或子文件夹（level-1）

对于Outlook.Session.Folders（MailBoxName）中的每个文件夹.Folders
如果VBA .UCase（Folder.Name）= VBA.UCase（Pst_Folder_Name）然后GoTo Label_Folder_Found
对于每个sFolders在Folder.Folders
如果VBA.UCase（sFolders.Name）= VBA.UCase（Pst_Folder_Name）然后
设置文件夹= sFolders
GoTo Label_Folder_Found
结束如果
下一个sFolders
下一个文件夹


Label_Folder_Found：
如果文件夹名称 =然后
MsgBox输入中的无效数据
GoTo End_Lbl1：
结束如果


'阅读每个邮件并导出详细信息Excel for Email Archival
ThisWorkbook.Sheets（3）.Activate

Folder.Items.sortReceived

'插入列标题
ThisWorkbook。 （3）.Cells（1，1）=Sender
ThisWorkbook.Sheets（3）.Cells（1，2）=Subject
ThisWorkbook.Sheets（3） ，3）=Date
ThisWorkbook.Sheets（3）.Cells（1，4）=发送
ThisWorkbook.Sheets（3）.Cells（1，5）=EmailID$ （3）.Cells（1，7）=Parent
'ThisWorkbook.Sheets（1） 1）.Cells（1，6）=Body

'从PST文件夹导出电子邮件数据
oRow = 1
设置vItems = Folder.Items
iRow = 1到vItems.Count
设置vItem = vItems.Item（iRow）
如果vItem.Class = 43然后
如果导入过去60天内收到的邮件的条件
'导入所有电子邮件，注释或删除此IF条件
如果VBA.DateValue（VBA.Now） - VBA.DateValue（vItem.ReceivedTime） = 10然后
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）.Cell s（oRow，8）= Folder.Items.Item（iRow）.Sent
'ThisWorkbook.Sheets（1）.Cells（oRow，6）= Folder.Items.Item（iRow）.Body
结束如果
结束如果
下一步iRow
MsgBox提取完成^。^
设置文件夹=没有
设置sFolders =没有

'sheet3_copypaste Macro

表格（Sheet3）。选择
ActiveWindow.SmallScroll Down：= - 33
范围（A2：H3001）。选择
应用程序.CutCopyMode = False
Selection.Copy
表格（完整列表）。选择
Selection.PasteSpecial粘贴：= xlPasteValues，操作：= xlNone，SkipBlanks _
：= False选择
列（D：E）选择
Selection.NumberFormat = m / d / yyyy h：mm
范围（D1）选择

'排序宏
范围（D6）选择
ActiveWorkbook .Worksheets（完整列表）sort.SortFields.Clear
ActiveWork book.Worksheets（完整列表）sort.SortFields.Add Key：= Range（D6），_
SortOn：= xlSortOnValues，Order：= xlAscending，DataOption：= xlSortNormal
With ActiveWorkbook 。（完整列表）排序
.SetRange范围（A5：I4976）
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
。应用
结束
范围（D1）。选择
End_Lbl1：
Application.RunModule5.OptimizeCode_End
End Sub

感谢您的关注。
任何问题我很乐意回答

解决方案

只是为了一致性，与excel和宏一个工作簿是一个完整的xlsm文件，其中包含工作表的集合（您将数据放入的各个选项卡）。通过分开的电子表格，我假设不同的工作簿。

这里是从电子表格获取数据的一些有用的代码。

底部的主要函数GetData，而不是存储在本地单元格中的数据，您只需将其放在变量中，并将其用于<

  Sub GetDataDemo（）
 
 Dim FilePath $，Row& Column& Address $ 
 
'更改常量&以下FilePath适合
'************************************* $ 
 Const FileName $ =Book1.xls
 Const SheetName $ =Sheet1
 Const NumRows& = 10 
 Const NumColumns& = 10 
 FilePath = ActiveWorkbook.Path& \
'************************************* $ 
 
 DoEvents 
 Application.ScreenUpdating = False 
如果Dir（FilePath& FileName）= Empty然后
 MsgBox文件& FileName& 没有找到，文件不存在
退出子
结束如果
对于行= 1到NumRows 
对于列= 1到NumColumns 
地址=单元格（行，列）.Address 
单元格（行，列）= GetData（FilePath，FileName，SheetName，Address）
 Columns.AutoFit 
下一列
下一行
 ActiveWindow.DisplayZeros = False 
 End Sub 
 
 
私有函数GetData（路径，文件，工作表，地址）
 Dim Data $ 
 Data ='&路径& [&文件& ]&片材& ！ &安培; _ 
范围（地址）.Range（A1）。地址（，，xlR1C1）
 GetData = ExecuteExcel4Macro（Data）
结束函数
  

如果它来自同一本书，您只需使用

  dim NUMDAYS as double 
 
 NUMDAYS = sheets（sheet2）。range（A1）。值分配给将在以后在宏中使用的变量。 
 
如果VBA.DateValue（VBA.Now） -  VBA.DateValue（vItem.ReceivedTime）< = NUM​​DAYS然后
  

To explain my title, basically i have a macro code which ill display in sec that is requesting number of days that need it to be exported from our shared mailbox. Now on a daily basis I have to change the number of days we need to export and is getting really frustrating. The following line is in question:

If VBA.DateValue(VBA.Now) - VBA.DateValue(vItem.ReceivedTime) <= 10 Then

That number 10 needs to change on a daily basis so i tried with active cell but no success as i get a runtime error 438.

So my question is: Is there a way that in a separated spreadsheet to input the number of days i need to export and that line in question can take the information from there and carry on with the code ?

Please see full code below.

    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

Thank you for taking interest. Any questions i'm happy to answer

解决方案

Just for consistency sake with excel and macros a workbook is a full xlsm file that contains a collection of worksheets (individual tabs that you put data on). By a seperated spreadsheet I'm assuming a different workbook.

Here is some useful code for getting data from a spreadsheet.

The main function GetData at the bottom, instead of storing the data in a local cell you would just put it in a variable and use that in your "<" statement.

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 

If its from the same workbook you would just use something like

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

这篇关于VBA从单元格更改的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！