Word 书签和工作表名称的数组

Question

我最近一直在做一些VBA的东西，但我不知道该采取什么方向。这里有人帮我复制了 Word，我失去了这个主题，但非常感谢！有没有更好的方法来阅读书签，我怎样才能让他们链接这一行中的正确工作表;

MyArray(i) 
'needs to go in to;
wb.worksheet(Myarray(i)).range("A1:BA3000")

我已经在阵列部分花费了很多时间。

Private Sub ranges()
Dim NamedRange As name
    Dim nm As name
    Dim ws As Worksheet
    Dim Lr As Long
    Dim Lc As Long
    Dim Rng As range
    Dim Bm As name
    Dim wb As Workbook
    Dim Fill As range
    Dim wd As Word.Application
Set wd = New Word.Application
    Set wb = ThisWorkbook 'Workbooks("C:Excel")
    Set aWs = ActiveSheet
'array with names of the word bookmarks
        Dim myArray(38)
myArray(0) = ("Tappunten")
myArray(1) = ("test1")
myArray(2) = ("Groslijst")
myArray(3) = ("J01_2")
myArray(4) = ("D01")
myArray(5) = ("D03")
myArray(6) = ("W01")
myArray(7) = ("W02")
myArray(8) = ("W03")
myArray(9) = ("W04")
myArray(10) = ("M01")
myArray(11) = ("M03")
myArray(12) = ("M04")
myArray(13) = ("M05")
myArray(14) = ("HJ01")
myArray(15) = ("J01")
myArray(16) = ("M02")
myArray(17) = ("J03")
myArray(18) = ("J04")
myArray(19) = ("J05")
myArray(20) = ("J06")
myArray(21) = ("J07")
myArray(22) = ("J08")
myArray(23) = ("J09")
myArray(24) = ("J10")
myArray(25) = ("J11")
myArray(26) = ("J12")
myArray(27) = ("J13")
myArray(28) = ("J14")
myArray(29) = ("J15")
myArray(30) = ("OT03")
myArray(31) = ("OT06")
myArray(32) = ("OT07")
myArray(33) = ("Checklist")
myArray(34) = ("ObjectGegevens")
myArray(35) = ("Grondstof")
myArray(36) = ("Drinkwaterinstallatie")
myArray(37) = ("WTB")
myArray(38) = ("Warmwaterleidingnet")
    'array for the worksheets on the excel sheets
        Dim myArray2(38)
myArray2(0) = Worksheets(1).name
myArray2(1) = Worksheets(1).name
myArray2(2) = Worksheets(42).name
myArray2(3) = Worksheets(17).name
myArray2(4) = Worksheets(2).name
myArray2(5) = Worksheets(15).name
myArray2(6) = Worksheets(22).name
myArray2(7) = Worksheets(3).name
myArray2(8) = Worksheets(28).name
myArray2(9) = Worksheets(29).name
myArray2(10) = Worksheets(4).name
myArray2(11) = Worksheets(6).name
myArray2(12) = Worksheets(29).name
myArray2(13) = Worksheets(46).name
myArray2(14) = Worksheets(7).name
myArray2(15) = Worksheets(16).name
myArray2(16) = Worksheets(5).name
myArray2(17) = Worksheets(13).name
myArray2(18) = Worksheets(12).name
myArray2(19) = Worksheets(47).name
myArray2(20) = Worksheets(9).name
myArray2(21) = Worksheets(13).name
myArray2(22) = Worksheets(14).name
myArray2(23) = Worksheets(14).name
myArray2(24) = Worksheets(32).name
myArray2(25) = Worksheets(1).name
myArray2(26) = Worksheets(1).name
myArray2(27) = Worksheets(1).name
myArray2(28) = Worksheets(1).name
myArray2(29) = Worksheets(8).name
myArray2(30) = Worksheets(19).name
myArray2(31) = Worksheets(33).name
myArray2(32) = Worksheets(18).name
myArray2(33) = Worksheets(27).name
myArray2(34) = Worksheets(25).name
myArray2(35) = Worksheets(36).name
myArray2(36) = Worksheets(26).name
myArray2(37) = Worksheets(20).name
myArray2(38) = Worksheets(38).name

i = 1
For Each nm In ThisWorkbook.Names
    If nm.Visible Then
        Set NamedRange = wb.Names.Item(i)
        Set ws = NamedRange.RefersToRange.Parent
    End If
        Lr = wb.worksheet(Myarray(i)).range("A1:BA3000").Find(What:="*", _ LookIn:=xlValues, _
            SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, 
            SearchFormat:=False).Row
        Lc = wb.worksheet(Myarray(i)).range("A1:BA3000").Find(What:="*", _ LookIn:=xlValues, _
            SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, _
            SearchFormat:=False).Column
    Set Rng = ws.range(ws.Cells(1, 1), ws.Cells(Lr, Lc))
With wd
        .Visible = True
        .WindowState = wdWindowStateMaximize
    With .Documents.Add(Template:="C:RABP sjabloon clean.dotx")
        With .Bookmarks
            myArray(i).range.PasteExcelTable LinkedToExcel:=False, _
                WordFormatting:=True, RTF:=False
            Rng.Copy ws.range(i)
        End With
    End With
End With
        i = i + 1
    Next nm
End Sub

Answer 1

有两种

方法可以填充数组：

方法一：

myArray = Split("Tappunten test1 Groslijst ...", " ")

方法2：

Sub LoopThroughBookmarks()
    Dim oBookmark As Bookmark
    Dim myArray() As String
    ReDim Preserve myArray(0)
    For Each oBookmark In ActiveDocument.Bookmarks
        ReDim Preserve myArray(UBound(myArray) + 1)
        myArray(UBound(myArray) - 1) = oBookmark.Name
    Next
End Sub

---

书签

将按照它们在文档中出现的顺序输入，您可能需要为书签添加一些验证，以免错误地添加一些书签。

我不知道如何将书签与第二个数组匹配：-/

Answer 2

我最终使用了这两段代码;

   Sub Copy_to_word()
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim i As Long
Dim names As Range
  Application.ScreenUpdating = False
  Application.EnableEvents = False
    'location of the word template
Const StrDocNm As String = "C:Word template V2.0.dotx"
If Dir(StrDocNm) = "" Then Debug.Print "file missing"
If Dir(StrDocNm) = MsgBox "Template not found"
If Dir(StrDocNm) = "" Then Exit Sub
   'Could probebly make it a bit neather
Set wdDoc = wdApp.Documents.Add(Template:=StrDocNm)
wdApp.Visible = True
   'All the named ranges have the same name as the bookmark
With ThisWorkbook
  For i = 1 To .names.Count
On Error GoTo LosseCell:
    .names(i).RefersToRange.Copy
    Debug.Print .names(i).Name
        'When the range is copied it starts the next macro.
        'if there's an error it goes tot the next name range 
    Call PasteBookmark(wdDoc, .names(i).Name)
LosseCell:
  Next
End With

Set wdDoc = Nothing: Set wdApp = Nothing
   'because it takes some time it had the events and screenupdating turned off
  Application.ScreenUpdating = True
  Application.EnableEvents = True

End Sub

第二个 marcro 是将范围粘贴到单词中的部分;

Sub PasteBookmark(wdDoc As Word.Document, strBkMk As String)
Dim wdRng As Word.Range
With wdDoc
  Application.ScreenUpdating = True 'not sure if this helps to be honest
  Application.EnableEvents = True   'not sure if this helps to be honest
  If .Bookmarks.Exists(strBkMk) Then
    Set wdRng = .Bookmarks(strBkMk).Range
 wdRng.Paste
    .Bookmarks.Add strBkMk, wdRng
  End If
End With
Set wdRng = Nothing
End Sub

由于范围的大小不同，我还有一个宏来调整行数可能不同的命名范围的大小;

Sub RangesAanpassen()
  Dim NmdRngNames As Variant
  Dim myLastRow As Long
  Dim StrWsNaam As String
  Dim strRangeNaam As String
  Dim namRange As Name
  Dim wsRange As Worksheet
  Dim n As Variant
  'the ranges that need to be resized are named the same as the sheets there
  'on. It gave a lot of troubles because the sheets had names like "D01". 
  'Had to change all of them to a name that didn't look like a cell.
  NmdRngNames = Array("D_03", "D_01", "J_01", "_6.4.3_Temperatuurmetingen", 
  "WTB", "Tappunten", "_6.4.2_Tappunten_inv", "Voorblad")
  Application.ScreenUpdating = False
  Application.EnableEvents = False

For Each n In NmdRngNames
strRangeNaam = n
On Error GoTo NextN: when the range is empty a "no object" error shows.
Set namRange = ActiveWorkbook.names.Item(strRangeNaam)
Set wsRange = Range(strRangeNaam).Worksheet
  With wsRange
      'the last cell can be anywhere in columns A to Z. 
    myLastRow = .Columns("A:Z").Find(What:="*", LookIn:=xlValues, _ 
    SearchDirection:=xlPrevious, _
    SearchOrder:=xlByRows).Row
  End With
  With namRange
    .RefersTo = wsRange.Range(wsRange.Cells(1, 1), _
                wsRange.Cells(myLastRow, 1))
  End With
NextN:
Next
  Application.ScreenUpdating = True
  Application.EnableEvents = True

End Sub

感谢伟大的论坛！