I am currently trying to copy an array into a table in a word doc, but I keep getting runtime error 5948 ("The requested member of the collection does not exist.") on the first call of doc.Tables(1).Columns(i).Cells(f).Select
and I am unsure of how to solve this. The loop which is supposed to write into the word table fails on i = 0.
EDIT: Added in the full code as well as a screenshot of my table.
Sub makeReport(lNum As Long, pDay As Date, name As String)
'Template Path: \COREMiscellaneousQualitySample ReportsTemplateDefect Report.dotm
'Save path for finished report: \COREMiscellaneousQualitySample Reports
'Initialize word objects and open word
Dim obj As Word.Application
Dim doc As Word.Document
Dim wdCell As Word.Cell
'MsgBox ("Word Doc Opened")
Set obj = New Word.Application
obj.Visible = True
Set doc = obj.Documents.Add(Template:=("\COREMiscellaneousQualitySample ReportsTemplateDefect Report.dotm"), NewTemplate:=False, DocumentType:=0)
doc.SaveAs2 Filename:="\COREMiscellaneousQualitySample Reports" + name, FileFormat:=wdFormatDocumentDefault, AddtoRecentFiles:=False
'MsgBox ("Word Objects Initialized")
'Fill in lot number and date at top of report
With doc
.Application.Selection.Find.Text = "<<date>>"
.Application.Selection.Find.Execute
.Application.Selection = Format(pDay, "mm/dd/yyyy")
.Application.Selection.EndOf
.Application.Selection.Find.Text = "<<lot>>"
.Application.Selection.Find.Execute
.Application.Selection = lNum
End With
'MsgBox ("Filled in pack date and lot number")
'Initialize excel objects
Dim wBook As Workbook
Dim wFunc As WorksheetFunction
Set wFunc = Application.WorksheetFunction
Set wBook = ThisWorkbook
Worksheets("Defect Table").Activate
Application.ActiveSheet.UsedRange.Select
'MsgBox ("Set Active Sheet to Defect Table")
'Initialize copy control variables
Dim x As Long
Dim y As Long
x = Selection.Rows.count
'MsgBox ("Number of rows: " + CStr(x))
Dim numArray() As Long
Dim dateArray() As Date
Dim hold(0 To 7) As Long
Dim b As Long
Dim msg As String
Dim c As Long
Dim d As Long
Dim e As Long
Dim f As Long
Dim g As Long
Dim i As Long
Dim temp As Variant
Dim sample(0 To 29) As Variant
i = 0
ReDim numArray(2 To x)
ReDim dateArray(2 To x)
For y = 2 To x
'Array which holds all lot numbers
numArray(y) = CInt(Application.ActiveSheet.Cells(y, 3).Value)
'Array which holds all dates
dateArray(y) = CDate(Application.ActiveSheet.Cells(y, 1).Value)
If (lNum = numArray(y) And pDay = dateArray(y)) Then
hold(i) = y
i = i + 1
End If
Next y
msg = "Appropriate samples found." + vbCrLf + "Rows: "
For i = 0 To 7
msg = msg + vbCrLf + CStr(hold(i))
Next i
MsgBox (msg)
'Copies samples over to word doc
For i = 0 To 7
d = hold(i)
If d = 0 Then
b = i
Exit For
End If
For c = 4 To 32
e = c - 4
If e = 30 Then
e = e + 1
c = c + 1
End If
sample(e) = ActiveSheet.Cells(d, c).Value
g = 1
For f = 0 To 32
Select Case f 'Accounts for blanks left in lines 6, 10, 16, 22, 30 of table in word doc
Case 0, 6, 10, 16, 22, 30
g = f + 1
Case Else
g = f
End Select
doc.Tables(1).Columns(i + 1).Cells(g).Select
obj.Selection.TypeText (sample(f))
f = f + 1
g = g + 1
Next f
Next c
If i = b Then
Exit For
End If
Next i
'---MsgBox ("Data copied to Word Doc")
'Saves Document using regular name format for ease of access
'---doc.SaveAs2 Filename:="\COREMiscellaneousQualitySample Reports" + name, FileFormat:=wdFormatDocumentDefault, AddtoRecentFiles:=False
'Zeroes out word/excel objects
'---Set doc = Nothing
'---Set obj = Nothing
'---Set wBook = Nothing
'---MsgBox ("Report saved and objects zeroed out")
End Sub
与恶龙缠斗过久,自身亦成为恶龙;凝视深渊过久,深渊将回以凝视…