在Outlook VBA中执行Excel函数的应用程序定义或对象定义的错误

我有一些代码将文件夹中的电子邮件正文提取为.xlsm文件。 提取后，文件保持打开状态，需要重新格式化才能将数据分离出单元格，然后将数据堆叠到单个列中。

这是我第一次在Outlook VBA编码，我觉得我有什么可能导致应用程序定义的错误有一些根本性的缺陷。

---

以下是电子邮件提取代码：

Sub OutlookToExcel() Dim appExcel As Excel.Application Dim wkb As Excel.Workbook Dim wks As Excel.Worksheet Dim rng As Excel.Range Dim strPath As String Dim intRowCounter As Integer Dim intColumnCounter As Integer Dim Msg As Outlook.MailItem Dim nms As Outlook.NameSpace Dim fld As Outlook.MAPIFolder Dim itm As Object strPath = "C:\Users\me\Documents\Action Items\WMV 856 load.xlsm" Debug.Print strSheet Set nms = Application.GetNamespace("MAPI") Set fld = nms.GetDefaultFolder(olFolderInbox).Folders("WMV Test") 'Open and activate Excel workbook. Set appExcel = CreateObject("Excel.Application") appExcel.Workbooks.Open (strPath) Set wkb = appExcel.ActiveWorkbook Set wks = wkb.Sheets(2) wks.Activate appExcel.Application.Visible = True 'Copy field items in mail folder. For Each itm In fld.Items intColumnCounter = 1 Set Msg = itm intRowCounter = intRowCounter + 1 Set rng = wks.Cells(intRowCounter, intColumnCounter) rng.Value = Msg.Body intColumnCounter = intColumnCounter + 1 Next itm 'Move items ' Set Vars Dim SubFolder As Outlook.MAPIFolder Dim Item As Object Dim lngCount As Long Dim Items As Outlook.Items ' Set Items Reference Set Items = fld.Items ' Loop through the Items For lngCount = Items.Count To 1 Step -1 Set Item = Items.Item(lngCount) Debug.Print Item.Subject If Item.Class = olMail Then ' // Set SubFolder of Inbox Set SubFolder = nms.GetDefaultFolder(olFolderInbox).Folders("WMV Done") ' // Mark As Read Item.UnRead = False ' // Move Mail Item to sub Folder Item.Move SubFolder End If Next lngCount SplitTextColumn <~~~Sub causing errors MakeOneColumn Set appExcel = Nothing Set wkb = Nothing Set wks = Nothing Set rng = Nothing Set Msg = Nothing Set nms = Nothing Set fld = Nothing Set itm = Nothing Exit Sub Set appExcel = Nothing Set wkb = Nothing Set wks = Nothing Set rng = Nothing Set Msg = Nothing Set nms = Nothing Set fld = Nothing Set itm = Nothing End Sub 

---

和数据操作代码（发生错误的地方，用<~~~表示）：

**注意：这些潜艇从Outlook VBA调用 – 这可能会导致问题？

 Sub SplitTextColumn() 'Takes all data out of one cell and splits it by line Dim i As Long Dim vA As Variant Dim i As Long Dim vA As Variant, rng As Range, c As Range Dim shtNew As Worksheet, sht As Worksheet Set sht = ActiveSheet Set rng = sht.Range(sht.Range("A1"), sht.Range("A1").End(xlDown)) For Each c In rng.Cells vA = Split(c.Value, vbLf) c.Offset(0, 1).Resize(1, UBound(vA) + 1).Value = vA '<~~~ Error on this line Next Set shtNew = Sheets.Add(After:=sht) sht.Range("A1").CurrentRegion.Offset(0, 1).Copy shtNew.Range("a1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=True End Sub 

Answer 1

通常你应该尽可能避免使用select/select（在你的代码中很less真正需要）

尝试这样的事情：

 Sub SplitTextColumn() 'Takes all data out of one cell and splits it by line Dim i As Long Dim vA As Variant, rng As Range, c As Range Dim shtNew As Worksheet, sht As Worksheet Set sht = ActiveSheet Set rng = sht.Range(sht.Range("A1"), sht.Range("A1").End(xlDown)) For Each c In rng.Cells vA = Split(c.Value, vbLf) c.Offset(0, 1).Resize(1, UBound(vA) + 1).Value = vA Next Set shtNew = Sheets.Add(After:=sht) sht.Range("A1").CurrentRegion.Offset(0, 1).Copy shtNew.Range("a1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=True End Sub