时间戳

首页 > 解决方案 > 在 Word 中复制动态范围直到行尾

regex - 在 Word 中复制动态范围直到行尾

问题描述

*** 我想我已经用 .MoveEndUntil 方法解决了我的问题，并将单词 doc 中的所有下一行替换为“*”，这样我就可以将范围更改为下一个符号，如下所示：

oRange.MoveEndUntil Cset:="*"

当我尝试通过下面的 VBA 将文本从 Word 复制到 Excel 时，我的复制技术遇到了问题。现在我有代码通过您选择的文件，对其进行一些格式更改（因为我不知道如何动态复制它），在文件中搜索字符串，对复制范围进行硬编码，然后粘贴Excel。我试图通过并在文档中迭代搜索的是以下信息：

所以我希望做的是在冒号之前搜索关键字，然后只复制冒号之后的范围直到行尾。这样，当我搜索“Building：”时，它会将“Central”从 word 复制并粘贴到指定的 Excel 单元格中，而无需进行所有硬编码 Range 移动。因为冒号后面的文本长度可能会因提交的信息而异。如果有人可以请提供任何帮助或指导，将不胜感激。我知道我的代码很脏而且不干净，但现在它可以满足我的需要，这就是我现在尝试改进它的原因。

Sub LocateSearchItem()
Dim shtSearchItem As Worksheet
Dim shtExtract As Worksheet
Dim oWord As Word.Application
Dim WordNotOpen As Boolean
Dim oDoc As Word.Document
Dim fd As Office.FileDialog
Dim FilePath As String
Dim oRange As Word.Range
Dim LastRow As Long ' last row with data in shtSearchItem
Dim CurrRowShtSearchItem As Long ' current row in shtSearchItem
Dim CurrRowShtExtract As Long ' current row in shtExtract
Dim myPara As Long


On Error Resume Next

Set oWord = GetObject(, "Word.Application")

If Err Then
    Set oWord = New Word.Application
    WordNotOpen = True
End If

On Error GoTo Err_Handler

oWord.Visible = True
oWord.Activate

Set fd = Application.FileDialog(msoFileDialogOpen)

With fd

    .Filters.Add "Word Files", "*.docx", 1
    .Title = "Choose a Word File"
    .AllowMultiSelect = False

    If .Show = True Then

        FilePath = .SelectedItems(1)
    End If
End With

Set oDoc = oWord.Documents.Open(FilePath)

With oDoc.Content.Find
        .Text = "Notes"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
    End With

With oDoc.Content.Find
        .Text = "^p"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
    End With

With oDoc.Content.Find
        .Text = "^l"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
    End With

oDoc.Save


Set shtSearchItem = ThisWorkbook.Worksheets(7)
If ThisWorkbook.Worksheets.Count < 2 Then
    ThisWorkbook.Worksheets.Add After:=shtSearchItem
End If
Set shtExtract = ThisWorkbook.Worksheets(5)

' AP name
For CurrRowShtSearchItem = 2 To 2
    Set oRange = oDoc.Range
    With oRange.Find
        .Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
        .Font.Name = "Helvetica"
        .MatchCase = False
        .MatchWholeWord = True
        While .Execute = True
            oRange.MoveEnd wdCharacter, 5

            CurrRowShtExtract = CurrRowShtExtract + 1

            shtExtract.Cells(CurrRowShtExtract + 1, 1) = oRange.Text

            oRange.Collapse wdCollapseEnd

        Wend
    End With
Next CurrRowShtSearchItem

CurrRowShtExtract = 0

'AP model
For CurrRowShtSearchItem = 3 To 3
    Set oRange = oDoc.Range
    With oRange.Find
        .Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
        .MatchCase = False
        .MatchWholeWord = True
        While .Execute = True
            oRange.MoveEnd wdCharacter, 6

            CurrRowShtExtract = CurrRowShtExtract + 1

            shtExtract.Cells(CurrRowShtExtract + 1, 20) = oRange.Text

            oRange.Collapse wdCollapseEnd

        Wend
    End With
Next CurrRowShtSearchItem

CurrRowShtExtract = 0

'Mounting Height
For CurrRowShtSearchItem = 4 To 4
    Set oRange = oDoc.Range
    With oRange.Find
        .Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
        .MatchCase = False
        .MatchWholeWord = True
        While .Execute = True
            oRange.MoveStart wdCharacter, 16
            oRange.MoveEnd wdCharacter, 11

            CurrRowShtExtract = CurrRowShtExtract + 1

            shtExtract.Cells(CurrRowShtExtract + 1, 22) = oRange.Text

            oRange.Collapse wdCollapseEnd

        Wend
    End With
Next CurrRowShtSearchItem

CurrRowShtExtract = 0

'Clip Type
For CurrRowShtSearchItem = 6 To 6
    Set oRange = oDoc.Range
    With oRange.Find
        .Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
        .MatchCase = False
        .MatchWholeWord = True
        While .Execute = True


            CurrRowShtExtract = CurrRowShtExtract + 1

            shtExtract.Cells(CurrRowShtExtract + 1, 19) = oRange.Text

            oRange.Collapse wdCollapseEnd

        Wend
    End With
Next CurrRowShtSearchItem

CurrRowShtExtract = 0

'Building
For CurrRowShtSearchItem = 7 To 7
    Set oRange = oDoc.Range
    With oRange.Find
        .Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
        .MatchCase = False
        .MatchWholeWord = True
        While .Execute = True

            CurrRowShtExtract = CurrRowShtExtract + 1

            shtExtract.Cells(CurrRowShtExtract + 1, 9) = oRange.Text

            oRange.Collapse wdCollapseEnd

        Wend
    End With
Next CurrRowShtSearchItem

CurrRowShtExtract = 0

'Floor
For CurrRowShtSearchItem = 8 To 8
    Set oRange = oDoc.Range
    With oRange.Find
        .Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
        .MatchCase = False
        .MatchWholeWord = True
        While .Execute = True

            CurrRowShtExtract = CurrRowShtExtract + 1

            shtExtract.Cells(CurrRowShtExtract + 1, 12) = oRange.Text

            oRange.Collapse wdCollapseEnd

        Wend
    End With
Next CurrRowShtSearchItem

CurrRowShtExtract = 0

'Room #
For CurrRowShtSearchItem = 9 To 9
    Set oRange = oDoc.Range
    With oRange.Find
        .Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
        .MatchCase = False
        .MatchWholeWord = True
        While .Execute = True

            CurrRowShtExtract = CurrRowShtExtract + 1

            shtExtract.Cells(CurrRowShtExtract + 1, 13) = oRange.Text

            oRange.Collapse wdCollapseEnd

        Wend
    End With
Next CurrRowShtSearchItem

CurrRowShtExtract = 0

'Antenna
For CurrRowShtSearchItem = 10 To 10
    Set oRange = oDoc.Range
    With oRange.Find
        .Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
        .MatchCase = False
        .MatchWholeWord = True
        While .Execute = True

            CurrRowShtExtract = CurrRowShtExtract + 1

            shtExtract.Cells(CurrRowShtExtract + 1, 21) = oRange.Text

            oRange.Collapse wdCollapseEnd

        Wend
    End With
Next CurrRowShtSearchItem

CurrRowShtExtract = 0

With oDoc.Content.Find
        .Text = "*Installation Instructions"
        .Replacement.Text = "Installation Instructions"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
oDoc.Save

'Installation
For CurrRowShtSearchItem = 5 To 5
    Set oRange = oDoc.Range
    With oRange.Find
        .Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
        .MatchCase = False
        .MatchWholeWord = True
        While oRange.Find.Execute = True
            oRange.Select
            myPara = oDoc.Range(0, oWord.Selection.Paragraphs(1).Range.End).Paragraphs.Count

            CurrRowShtExtract = CurrRowShtExtract + 1

            shtExtract.Cells(CurrRowShtExtract + 1, 14) = Left(oDoc.Paragraphs(myPara).Range, Len(oDoc.Paragraphs(myPara).Range) - 1)

            oRange.Collapse wdCollapseEnd

        Wend
    End With
Next CurrRowShtSearchItem

Cells.Replace What:="Installation Instructions:", Replacement:="", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

Columns("U:U").Select
    Selection.Replace What:="m*", Replacement:="m", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

If WordNotOpen Then
    oWord.Quit
End If

If WordNotOpen Then
    oWord.Quit
End If

'Release object references

Set oWord = Nothing
Set oDoc = Nothing

Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
If WordNotOpen Then
oWord.Quit
End If

End Sub

标签： regexexcelvbams-word

解决方案

假设您的活动工作表在 A 列中有模型、天线等，并且找到的详细信息将输出到 B 列：

Sub GetDocData()
Dim xlSheet As Worksheet, r As Long
Dim WordApp As New Word.Application, WordDoc As Word.Document
Set xlSheet = ActiveSheet
WordApp.Visible = True
With WordApp
  .Visible = False
  With .Dialogs(wdDialogFileOpen)
    If .Show = -1 Then
      Set WordDoc = WordApp.ActiveDocument
    End If
  End With
  With WordDoc
    With .Range
      For r = 1 To xlSheet.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
        With .Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Replacement.Text = ""
          .Forward = True
          .Format = False
          .Wrap = wdFindContinue
          .Text = xlSheet.Range("A" & r) & ":"
          .Execute
        End With
        If .Find.Found = True Then
            .Collapse wdCollapseEnd
            .End = .Paragraphs.First.Range.End - 1
            xlSheet.Range("B" & r).Value = .Text
        End If
      Next
    End With
  End With
End With
End Sub

推荐阅读