Определенная пользователем или объектно-зависимая ошибка, выполняющая функции excel в Outlook VBA

Question

У меня есть код для извлечения тела писем в папке в файл .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/выбор как можно больше (и это редко действительно необходимо в вашем коде)

Попробуйте что-то вроде этого:

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