我有大量檔案需要從中提取檔案名參考，分布在大塊文本和腳注中。
我目前有一個單詞 VBA 代碼，我認為它應該搜索一個字串（例如“This_”），然后是以下 # 個字符，然后將它們粘貼到等待的 Excel 表中。我正在努力讓它同時搜索腳注和正文。
我一直在使用下面的代碼，但我目前的作業是讓它做一些奇怪的事情。它會找到我正在搜索的字串，但隨后它將從檔案的開頭復制找到該字串的次數——而不是字串及其后續文本。
任何幫助都將不勝感激，我相信問題將來自“將資料回傳到陣列”部分的前半部分。
Option Explicit
Option Base 1
Sub WordDataToExcel()
Dim myObj
Dim myWB
Dim mySh
Dim txt As String, Lgth As Long, Strt As Long
Dim i As Long
Dim oRng As Range
Dim Tgt As String
Dim TgtFile As String
Dim arr()
Dim ArrSize As Long
Dim ArrIncrement As Long
ArrIncrement = 1000
ArrSize = ArrIncrement
ReDim arr(ArrSize)
'Set parameters Change to your path and filename
TgtFile = "File.xlsx"
If IsWindowsOS Then
Tgt = "C:\users\user\" & TgtFile ' Windows OS
Else
Tgt = "MacintoshHD:Users:" & TgtFile 'Mac OS
End If
txt = InputBox("String to find")
Lgth = InputBox("Length of string to return")
Strt = Len(txt)
'Return data to array
ActiveDocument.StoryRanges(wdFootnotesStory).Select
With Selection.Find
.ClearFormatting
.Forward = True
.Text = txt
.MatchCase = True
.Execute
While .Found
i = i 1
Set oRng = ActiveDocument.Range _
(Start:=Selection.Range.Start Strt, _
End:=Selection.Range.End Lgth)
arr(i) = oRng.Text
oRng.Start = oRng.End
.Execute
If i = ArrSize - 20 Then
ArrSize = ArrSize ArrIncrement
ReDim Preserve arr(ArrSize)
End If
Wend
End With
ReDim Preserve arr(i)
'Set target and write data
Set myObj = CreateObject("Excel.Application")
Set myWB = myObj.workbooks.Open(Tgt)
Set mySh = myWB.sheets(1)
With mySh
.Range(.Cells(1, 1), .Cells(i, 1)) = myObj.transpose(arr)
End With
'Tidy up
myWB.Close True
myObj.Quit
Set mySh = Nothing
Set myWB = Nothing
Set myObj = Nothing
End Sub
Public Function IsWindowsOS() As Boolean
If Application.System.OperatingSystem Like "*Win*" Then
IsWindowsOS = True
Else
IsWindowsOS = False
End If
End Function
uj5u.com熱心網友回復：
您的代碼有點混亂，因為 和 混合Selection在一起Range。避免使用是一種很好的做法，Selection因為在 VBA 中作業時很少需要選擇任何內容。
VBA 還具有編譯器常量，可用于檢測代碼是否在 Mac 上運行。不確定 Mac 常量是否仍然可以可靠地作業，因為我不再需要對其進行測驗。
'Set parameters Change to your path and filename
TgtFile = "File.xlsx"
'This isn't necessary as there is a compiler constant that can be used to identify code is running on Mac
' If IsWindowsOS Then
' Tgt = "C:\users\user\" & TgtFile ' Windows OS
' Else
' Tgt = "MacintoshHD:Users:" & TgtFile 'Mac OS
' End If
#If Mac Then
Tgt = "MacintoshHD:Users:" & TgtFile 'Mac OS
#Else
Tgt = "C:\users\user\" & TgtFile ' Windows OS
#End If
txt = InputBox("String to find")
Lgth = InputBox("Length of string to return")
Strt = Len(txt)
'Return data to array
'not necessary to select the story range
'ActiveDocument.StoryRanges(wdFootnotesStory).Select
Set oRng = ActiveDocument.StoryRanges(wdFootnotesStory)
With oRng
With .Find
.ClearFormatting
.Forward = True
.Text = txt
.MatchCase = True
End With
While .Find.Execute
'a match has been found and oRng redefined to the range of the match
i = i 1
.MoveEnd wdCharacter, Lgth
arr(i) = .Text
.Collapse wdCollapseEnd
If i = ArrSize - 20 Then
ArrSize = ArrSize ArrIncrement
ReDim Preserve arr(ArrSize)
End If
Wend
End With
uj5u.com熱心網友回復：
例如，以下代碼回傳找到的文本及其頁面參考：
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, StrFnd As String, StrOut As String
StrFnd = InputBox("String to find")
j = InputBox("String Length to find")
k = j - Len(StrFnd)
For i = 1 To k
StrFnd = StrFnd & "^?"
Next
With ActiveDocument
For i = 1 To 2 ' 1 = wdMainTextStory, 2 = wdFootnotesStory, 3 = wdEndnotesStory, etc.
With .StoryRanges(i)
With .Find
.ClearFormatting
.Text = StrFnd
.Forward = True
.Format = True
.MatchWildcards = False
.Wrap = wdFindStop
.Replacement.Text = ""
End With
Do While .Find.Execute = True
StrOut = StrOut & vbCr & .Text & vbTab
Select Case .StoryType
Case wdMainTextStory
StrOut = StrOut & .Information(wdActiveEndAdjustedPageNumber)
Case wdFootnotesStory
StrOut = StrOut & .Duplicate.Footnotes(1).Reference.Information(wdActiveEndAdjustedPageNumber)
End Select
Loop
End With
Next
End With
MsgBox StrOut
Application.ScreenUpdating = True
End Sub
uj5u.com熱心網友回復：
這是如何搜索檔案的多個部分的示例。請注意，我使用 aCollection來收集專案，因此您不必不斷增加陣列。
Option Explicit
Option Base 1
Sub test()
Dim allFound As Collection
Set allFound = TextFoundReport("This_", 10)
Dim entry As Variant
For Each entry In allFound
Dim partType As Long
Dim text As String
Dim tokens() As String
tokens = Split(entry, "|")
'--- here is where you copy to an Excel sheet
Debug.Print "Part type: " & tokens(0) & " - '" & tokens(1) & "'"
Next entry
End Sub
Private Function TextFoundReport(ByVal text As String, _
ByVal numberOfCharacters As Long) As Collection
Dim whatWeFound As Collection
Set whatWeFound = New Collection
'--- create a list of the document parts to search
Dim docParts As Variant
docParts = Array(wdMainTextStory, wdFootnotesStory, wdEndnotesStory, wdCommentsStory)
Dim foundRng As Range
Dim docPart As Variant
For Each docPart In docParts
ActiveDocument.StoryRanges(docPart).Select
'--- find all occurences in this part and add it to the collection
' the Item in the collection is the story type and the found text
With Selection.Find
.ClearFormatting
.Forward = True
.text = text
.MatchCase = True
.Execute
Do While .found
Set foundRng = ActiveDocument.Range _
(Start:=Selection.Range.Start Len(text), _
End:=Selection.Range.End numberOfCharacters)
whatWeFound.Add CLng(docPart) & "|" & foundRng.text
foundRng.Start = foundRng.End
.Execute
Loop
End With
Next docPart
Set TextFoundReport = whatWeFound
End Function
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/454704.html