1

私のプロジェクトは、聖書全体の単語/フレーズを変更することであり、聖書を含む Word ドキュメントがあり、別に、マクロで見つける必要がある列 A の古い単語、列 B の新しい単語を含む Excel ファイルがあります。古いものを交換します。

このマクロは MS Word 2010 で適切に機能しますが、ご覧のとおり、Data 配列を使用するように設定されています。「注: この例ではデータ配列が使用されています。実際には、データは Word テーブル、Excel ワークシート、またはその他のデータ ソースから取得できます。」. そのため、変更する必要があるすべての単語/フレーズを含む Excel ファイルからデータを取得するように調整する必要があります。

2 つのクラス モジュールと 1 つの標準モジュールがあります。しかし、この投稿の最後に、必要なことを実行する (Excel ファイルからデータを取得する) コードをさらに追加しますが、マクロで動作するように調整する必要があります。問題は、それを適応させる方法がわからないことです。言い換えれば、モジュールを機能させるために何を置き換える必要があるのか​​ わかりません。

また、Excel ファイルはシンプルである必要があると思います。列 A 古い語句 // 列 B 新しい語句。それだけでうまくいくのでしょうか？

これが私が持っているすべてです（個別に）：

最初のクラス モジュールに「clsTerm」という名前を付けて、次のコードを貼り付けるように言われました。

Option Explicit

Private English                 As String
Private Hebrew                  As String
Private FNT                     As String

Property Let EnglishTerm(strVal As String)
    English = strVal
End Property

Property Get EnglishTerm() As String
    EnglishTerm = English
End Property

Property Let HebrewTerm(strVal As String)
    Hebrew = strVal
End Property

Property Get HebrewTerm() As String
    HebrewTerm = Hebrew
End Property

Property Let FootnoteText(strVal As String)
    FNT = strVal
End Property

Property Get FootnoteText() As String
    FootnoteText = FNT
End Property

2 番目のクラス モジュールに「clsTerms」という名前を付けて、次のコードを貼り付けるように言われました。

Option Explicit

Private colTerms                As Collection
Private lngCount                As Long

Property Get Items() As Collection
    Set Items = colTerms
End Property

Property Set Items(oCol As Collection)
    Set colTerms = oCol
End Property

Property Get Count() As Long
    If Not colTerms Is Nothing Then
        Count = colTerms.Count
    Else
        Count = 0
    End If
End Property

次に、標準モジュールを作成し、「Anything I like」という名前を付けて、次のコードを貼り付けるように指示されました。

Option Explicit

Dim m_oCol1                     As Collection
Dim m_oCol2                     As Collection

Sub ReplaceWordsAndDefineFootnotes()
    Dim clsTL                   As clsTerms
    Dim lngIndex                As Long

    Set clsTL = New clsTerms
    Set clsTL.Items = DefinedTerms
    Set m_oCol1 = New Collection
    For lngIndex = 1 To clsTL.Count
        'Replace each defined English word with it Hebrew equivelent.
        ReplaceWords clsTL.Items(lngIndex).EnglishTerm, clsTL.Items(lngIndex).HebrewTerm
    Next lngIndex
    Underline_And_DefineFootnote
    For lngIndex = 1 To clsTL.Count
        'Replace temporary footnote text with with class defined footnote text.
        FixFootnotes clsTL.Items(lngIndex).HebrewTerm, clsTL.Items(lngIndex).FootnoteText
    Next lngIndex
lbl_Exit:
    Exit Sub
End Sub

Function DefinedTerms() As Collection
    Dim arrEng()                As String
    Dim arrHeb()                As String
    Dim lngIndex                As Long
    Dim oCol                    As Collection
    Dim Term                    As clsTerm

    'Note: Data arrays are used in this example.  In practice the data could come from a Word table, Excel worksheet or other data source.
    arrEng = Split("God,heaven,earth,waters,good", ",")
    arrHeb = Split("Elohim,shamayim,aretz,mayim,tov", ",")

    Set oCol = New Collection
    'Put data in the collection.
    For lngIndex = 0 To UBound(arrEng)
        Set Term = New clsTerm
        Term.EnglishTerm = arrEng(lngIndex)
        Term.HebrewTerm = arrHeb(lngIndex)
        Term.FootnoteText = arrEng(lngIndex) & ":" & arrHeb(lngIndex)
        oCol.Add Term, Term.EnglishTerm
    Next lngIndex
    Set DefinedTerms = oCol
lbl_Exit:
    Exit Function
End Function

Sub ReplaceWords(ByVal strFind As String, ByVal strReplaceWith As String)
    Dim oRng                    As Word.Range
    'Add each term processed to a collection.
    m_oCol1.Add UCase(strReplaceWith), UCase(strReplaceWith)
    Set oRng = ActiveDocument.Range
    'Replace each instance of the English word with its Hebrew equivalent.
    With oRng.Find
        .Text = strFind
        .Replacement.Text = strReplaceWith
        .MatchWholeWord = True
        .MatchCase = False
        .Execute Replace:=wdReplaceAll
    End With
lbl_Exit:
    Exit Sub
End Sub

Sub Underline_And_DefineFootnote()
    Dim oRng                    As Word.Range
    Dim lngIndex                As Long
    Dim oWord                   As Word.Range
    Dim strWord                 As String
    Dim lngCounter              As Long
    Dim lngPages                As Long

    With ActiveDocument
        Set oRng = .Range
        lngPages = .ComputeStatistics(wdStatisticPages)
        For lngIndex = 1 To lngPages
Reprocess:
            Set m_oCol2 = New Collection
            Set oRng = oRng.GoTo(What:=wdGoToPage, Name:=lngIndex)
            Set oRng = oRng.GoTo(What:=wdGoToBookmark, Name:="\page")
            lngCounter = 1
            With oRng
                For Each oWord In oRng.Words
                    'Modify the word range to strip off white space.  We want only the text portion of the word range.
                    strWord = UCase(Trim(oWord.Text))
                    oWord.Collapse wdCollapseStart
                    oWord.MoveEnd wdCharacter, Len(strWord)
                    If oWord.Characters.Last = Chr(160) Then oWord.MoveEnd wdCharacter, -1
                    'We need to know if the text defined by the word range is a word we want to process.
                    'We added all of those words to a collection during the find and replace process.
                    'If we try to add one of those words to the collection again then it will error and we will know _
                     we are dealing with a word we want to process.
                    On Error Resume Next
                    m_oCol1.Add strWord, strWord
                    If Err.Number <> 0 Then
                        On Error GoTo 0
                        On Error Resume Next
                        'We only want to underline and footnote the first instance of the term on each page.
                        'So add the term and key to a collection.
                        m_oCol2.Add strWord, strWord
                        If Err.Number = 0 Then
                            'There was no error so underline the term and footnote it.
                            oWord.Font.Underline = 1
                            On Error GoTo 0
                            ActiveDocument.Footnotes.Add oWord, CStr(lngCounter), LCase(strWord)
                            lngCounter = lngCounter + 1
                        End If
                    Else
                        'The word wasn't a word we want to process so remove it from the collection.
                        m_oCol1.Remove m_oCol1.Count
                    End If
                Next oWord
            End With
            'Since processing words will add footnotes, the length of the document will increase.
            'I'm using this method to reenter the processing loop.
            lngPages = .ComputeStatistics(wdStatisticPages)
            If lngIndex < lngPages Then
                lngIndex = lngIndex + 1
                GoTo Reprocess
            End If
        Next lngIndex
    End With
    Set oRng = Nothing
End Sub

Sub FixFootnotes(ByVal strFind As String, ByVal strReplaceWith As String)
    Dim oRng                    As Word.Range
    m_oCol1.Add UCase(strReplaceWith), UCase(strReplaceWith)
    Set oRng = ActiveDocument.StoryRanges(wdFootnotesStory)
    With oRng.Find
        .Text = strFind
        .Replacement.Text = strReplaceWith
        .MatchWholeWord = True
        .MatchCase = False    'True
        .Execute Replace:=wdReplaceAll
    End With
lbl_Exit:
    Exit Sub
End Sub

最後に、Excel ファイルからデータを取得するためにマクロに適用する必要があるコードは次のとおりです。

Sub ListFromExcel()
Dim lngIndex As Long
Dim arrWords As Variant
'Find words in column 1, Replace words in column 2
arrWords = GetListArray(You file path and name)
For lngIndex = 2 To UBound(arrWords, 1)
  Debug.Print arrWords(lngIndex, 1)
  Debug.Print arrWords(lngIndex, 2)
Next
End Sub

Function GetListArray(ByRef strFileName As String) As Variant
Dim xlapp As Object
Dim xlbook As Object
Dim xlsheet As Object
Dim bAppStart As Boolean
  On Error Resume Next
  Set xlapp = GetObject(, "Excel.Application")
  If Err Then
    bAppStart = True
    Set xlapp = CreateObject("Excel.Application")
  End If
  On Error GoTo 0
  Set xlbook = xlapp.Workbooks.Open(FileName:=strFileName)
  Set xlsheet = xlbook.Worksheets(1)
  GetListArray = xlsheet.Range("A1").CurrentRegion.Value
  xlbook.Close
  If bAppStart = True Then xlapp.Quit
  Set xlapp = Nothing
  Set xlbook = Nothing
  Set xlsheet = Nothing
lbl_Exit:
  Exit Function
End Function
4

1 に答える 1

1

最初のサブをこれに変更します

Sub ReplaceWordsAndDefineFootnotes()
    Dim clsTL                   As clsTerms
    Dim lngIndex                As Long

    Set clsTL = New clsTerms
    clsTL.FillFromExcel
    Set m_oCol1 = New Collection
    For lngIndex = 1 To clsTL.Count
        'Replace each defined English word with it Hebrew equivelent.
        ReplaceWords clsTL.Items(lngIndex).EnglishTerm, clsTL.Items(lngIndex).HebrewTerm
    Next lngIndex
    Underline_And_DefineFootnote
    For lngIndex = 1 To clsTL.Count
        'Replace temporary footnote text with with class defined footnote text.
        FixFootnotes clsTL.Items(lngIndex).HebrewTerm, clsTL.Items(lngIndex).FootnoteText
    Next lngIndex
lbl_Exit:
    Exit Sub
End Sub

これを clsTerms クラスに追加します

Public Sub FillFromExcel()

    Dim xlApp As Object
    Dim xlWb As Object
    Dim vaWords As Variant
    Dim cTerm As clsTerm
    Dim i As Long

    Const sFILE As String = "C:\Users\Dick\Documents\My Dropbox\Excel\wordlist.xlsx"
    Const xlUP As Long = -4162

    Set colTerms = New Collection

    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Open(sFILE, , True)

    With xlWb.Worksheets(1)
        vaWords = .Range("A1", .Cells(.Rows.Count, 2).End(xlUP)).Value
    End With

    For i = LBound(vaWords, 1) To UBound(vaWords, 1)
        Set cTerm = New clsTerm
        cTerm.EnglishTerm = vaWords(i, 1)
        cTerm.HebrewTerm = vaWords(i, 2)
        cTerm.FootnoteText = vaWords(i, 1) & ":" & vaWords(i, 2)
        colTerms.Add cTerm
    Next i

    xlWb.Close False
    xlApp.Quit

End Sub
于 2013-09-29T01:27:07.077 に答える