1

VBAを学び始めたばかりなので、VBAは初めてです。

現在、メッセージ本文をOutlookからExcelにエクスポートする際に問題が発生しています。面白いのは、私が最初に走ったとき、それはうまくいくということです。しかし、2回目に実行すると、タイトルに記載されているエラーメッセージが表示されます。

デバッグをクリックすると、次のコードが強調表示されました： "offsetRow = Cells（Rows.Count、1）.End（xlUp）.Row"

データを貼り付けたいワークシートを選択するなど、さまざまな方法を試しましたが、役に立ちませんでした。したがって、ここの専門家がコードのデバッグを手伝ってくれることを願っています。また、コンピューターの速度を低下させる冗長性を実行した場合は、コーディングについてフィードバックしてください。

参考までに、これは私の仕事のためであり、メールの内容をExcelにエクスポートできるようにするためのものです。前もって感謝します。

Sub ExportToExcel()

Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
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
Dim masterData() As String
Dim subData() As String
Dim i As Integer
Dim offsetRow As Long

strSheet = "For fun.xlsx"
strPath = "C:\Users\XXXXX\Desktop\New folder\"
strSheet = strPath & strSheet

Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder

'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
    MsgBox "Thank you for using this service.", vbOKOnly, "Error"
    Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
    MsgBox "Please select the correct folder.", vbOKOnly, "Error"
    Exit Sub
ElseIf fld.Items.Count = 0 Then
    MsgBox "There are no mail messages to export", vbOKOnly, "Error"
    Exit Sub
End If

'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
    appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets("Sheet1")

wks.Activate
appExcel.Application.Visible = True  

'Copy field items in mail folder.
For Each itm In fld.Items
    Set msg = itm
    masterData = Split(msg.Body, vbCrLf) 'Seperate according to lines
    For i = 0 To UBound(masterData)
        If masterData(i) = "" Then
            'Do nothing
        Else
            'do the split here
            subData = Split(masterData(i), vbTab)
            wks.Activate
            offsetRow = Cells(Rows.Count, 1).End(xlUp).Row 'This is where the error appears
            If i = 0 Then
                intRowCounter = i + offsetRow + 1
            Else
                intRowCounter = i + offsetRow
            End If
            For intColumnCounter = 0 To UBound(subData)
                Set rng = wks.Cells(intRowCounter, intColumnCounter + 1)
                rng.Value = subData(intColumnCounter)
            Next intColumnCounter
        End If
    Next i
Next itm

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
4

2 に答える 2

1

私は変更しました：

offsetRow = Cells(Rows.Count, 1).End(xlUp).Row

の中へ

With wks
    offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With

そしてそれは今動作します。

于 2013-01-06T02:47:41.320 に答える