Question

您好我有以下代码成功遍历我的文件夹并提取我想要的电子邮件并将正文（以表格格式）复制到Excel中。但是，当我粘贴它时，如果我手动复制并粘贴它，它应该填充A1：K92范围，整个体被粘贴在单元格A1中。有什么方法可以使用vba将其粘贴到正确的范围内？谢谢！

Sub GetFXEmail()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMi As Variant
Dim i As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set Fldr = Fldr.Folders("MyFolder")
Set inboxItems = Fldr.Items

pnldate = Format((Date - 1), "mm/dd/yyyy")

Set inboxItems = Fldr.Items
inboxItems.Sort "[ReceivedTime]", True
For i = 1 To Fldr.Items.Count Step 1
    Set olMi = Fldr.Items(i)
        If Format(olMi.ReceivedTime, "mm/dd/yyyy") = pnldate Then
            Debug.Print olMi.ReceivedTime
            Debug.Print olMi.Subject
            If InStr(1, olMi.Subject, "Breakdown") > 0 Then
                Sheets("Sheet1").Range("A1") = olMi.Body
                GoTo AllDone
            End If
        End If
Next i

AllDone:
End Sub

Answer 1

如果您在电子邮件中只有一个表格并且它被识别为实际表格，则此代码（将放置在第一个If块内）将起作用（并且已经过测试） 。如果需要，您可以修改零件以满足您的确切需求。

另请注意，它需要引用Microsoft Word对象库（因为您已经有Outlook对象库）。

If Format(olMi.ReceivedTime, "mm/dd/yyyy") = pnldate Then

    With olMi

        Debug.Print .ReceivedTime
        Debug.Print .Subject

        Dim olInsp As Outlook.Inspector
        Set olInsp = .GetInspector

        Dim wdDoc As Word.Document
        Set wdDoc = olInsp.WordEditor

        Dim tb As Word.Table
        For Each tb In wdDoc.Tables 'assumes only 1 table
            Dim y as Long, x as Long
            For y = 0 To tb.Rows.Count
                For x = 0 To tb.Columns.Count
                    Sheets("Sheet1").Range("A1").Offset(y, x).Value = tb.Cell(y, x).Range.Text
                Next
            Next
        Next

    End With

    GoTo AllDone

End If

Answer 2

即使苏格兰人给你一个很好的答案，我给出了答案，也许可以帮助别人。

这将获取字符串，并创建一个表，解析数据，在excel内部，偏移1列，但这可以使用.copy来修复。

Sub convertToTable()
    Dim bigString As String
    Dim i
    Dim lenString
    Dim n
    Dim typeChar
    Dim r
    Dim rng As Range
    Dim lineLen
    Dim a
    Dim tLen
    Dim textR

    bigString = Range("A1").Value 'take the value from A1
    lenString = Len(bigString) 'take the lenght

    Do 'go over the string spliting by the new line character (char10)
        i = i + 1 'just the index
        Range(Cells(i, 1), Cells(i, 1)).Value = Left(bigString, InStr(1, bigString, Chr(10)))
        'important:
        'use the col 1 to put the values in the sheet, here we split just into rows
        'you can change the value of the column as you want
        bigString = Right(bigString, Len(bigString) - InStr(1, bigString, Chr(10)))
        'here adjust the string to the rest of the text
    Loop While i < lenString

    r = Range(Cells(1, 1), Cells(1, 1)).End(xlDown).Row 'same as Range("A1").End
    Set rng = Range(Cells(1, 2), Cells(r, 2)) 'the whole range of data in col A

    a = 1 'here set 1 to use the column B (a = a + 1)
          'if we delete the data there will be a trouble
    For Each i In rng 'for each cell/row in the data range in column A
        tLen = Len(i.Value) 'the lenght
        textR = i.Value 'the text
        Do
            a = a + 1 'the next column...
            Cells(i.Row, a).Value = Left(textR, InStr(1, textR, Chr(32)))
            'Left(textR, InStr(1, textR, Chr(32)))
            'this split the values using the space char (Chr(32)), but you can
            'change it as you need, just find the spliting character
            textR = Right(textR, Len(textR) - InStr(1, textR, Chr(32)))
        Loop While InStr(1, textR, Chr(32)) <> 0
        a = 1
    Next i
End Sub

vba复制电子邮件正文作为表格

2 个答案: