我最近一直在做一些VBA的事情，但我不知道要采取什么方向。 这里有人帮我复制到Word，我已经失去了主题，但非常感谢！ 是否有更好的方式来阅读BookMarks以及如何让他们链接这一行中的正确表格;
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
答案 0 :(得分：0)
您可以通过两种方式填充数组：
方法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
书签将按照文档中出现的顺序输入，您可能希望为书签添加一些验证，这样您就不会错误地添加一些书签。
我不知道如何将书签与第二个数组匹配： - /
答案 1 :(得分：0)
我最终使用了这两段代码;
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
感谢这个伟大的论坛！