Shezageek
10-21-2009, 12:41 PM
I have a rather large project that works great except for one issue. One userform calls in a table through the listbox command. You can pick and choose which line of the external table you want to insert into the newly created table, however, you cannot enter more than 44 lines and there are times when an end user would need to add as many as 100 lines. There is an error "in button click The requested member of the collection does not exist".
Can anyone tell me what/where this code needs to be edited and how so that more than 44 lines of data can be added?
Thanking you in advance for any help you may have to offer.
Const DOCPATH As String = "C:\RBCTable"
Private Sub UserForm_Initialize()
Dim aRange1 As Range
Dim adoc1 As Document
Dim adoc2 As Document
Set adoc1 = ActiveDocument
Set aRange1 = ActiveDocument.Bookmarks("BKRevenueReport").Range.Tables(1).Range
Dim i As Integer
Dim blnOpen As Boolean
On Error GoTo errhandler
Application.ScreenUpdating = False
For i = 1 To Documents.Count
If Documents(i).Name = "Table.doc" Then
blnOpen = False
Exit For
Else
blnOpen = True
End If
Next i
If blnOpen = False Then
'do nothing doc already opened
Else
ChangeFileOpenDirectory DOCPATH
Documents.Open DOCPATH & "\Table.doc", _
addtoRecentFiles:=no, Visible:=no
End If
Set adoc2 = Documents("Table.doc")
With adoc2.Tables(1)
For i = 2 To .Rows.Count
Dim strresult As String
strresult = .Cell(i, 2).Range.Text
strresult = Left(strresult, Len(strresult) - 1)
Me.ListBox1.AddItem strresult
Next i
adoc1.Activate
End With
Dim j As Integer
With aRange1
For i = 2 To .Rows.Count - 1
strresult = .Rows(i).Cells(2).Range.FormFields(1).Result
For j = 0 To Me.ListBox1.ListCount - 1
If strresult = Me.ListBox1.List(j) Then
Me.ListBox1.Selected(j) = True
End If
Next j
Next i
End With
Application.ScreenUpdating = True
Application.ScreenRefresh
Exit Sub
errhandler:
MsgBox "in initialize " & Err.Description
End Sub
Private Sub CommandButton1_Click()
Dim intRownumindoc As Integer
Dim intrownumindata As Integer
Dim i As Integer
Dim j As Integer
Dim strDoc1 As String
Dim strDoc2 As String
Dim blnAdd As Boolean
On Error GoTo errhandler
strDoc1 = ActiveDocument.Name
Call ThisDocument.unprotectDocument
strDoc2 = "Table.doc"
With ActiveDocument.Bookmarks("BKRevenueReport").Range.Tables(1)
For i = 0 To Me.ListBox1.ListCount - 1
blnAdd = True
If Me.ListBox1.Selected(i) = True Then
For j = 2 To .Rows.Count - 1
If .Rows(j).Cells(2).Range.Fields(1).Result = Me.ListBox1.List(i) Then
'the row has already been added ' do not do anything
blnAdd = False
Exit For
End If
Next j
Select Case blnAdd
Case True
Documents(strDoc1).Activate
Call mdlRevenue.createNewRow
intRownumindoc = calculateRowNumber
Documents(strDoc2).Activate
intrownumindata = calculateRowNumberInData(Me.ListBox1.List(i))
Documents(strDoc1).Activate
Call populateFields(intRownumindoc, intrownumindata, strDoc1, strDoc2)
Documents(strDoc1).Tables(1).Rows(intRownumindoc).Range.Select
Call AddControlsToTable(intRownumindoc)
Selection.Rows(1).Cells(2).Range.FormFields(1).Result = Me.ListBox1.List(i)
End Select
Else
For j = 2 To .Rows.Count - 1
If .Rows(j).Cells(2).Range.Fields(1).Result = Me.ListBox1.List(i) Then
'rows was previously added to document but has now to be deleted
.Rows(j).Delete
Exit For
End If
Next j
End If
Next i
Dim intTotalRows As Integer
intTotalRows = .Rows.Count
.Rows(intTotalRows).Select
Selection.Fields.Update
End With
Documents("Table.doc").Close
Documents(strDoc1).Activate
With ActiveDocument.Bookmarks("BKRevenueReport").Range.Tables(1)
If .Rows.Count > 2 Then
.Rows(2).Cells(10).Range.FormFields(1).Select
Else
ActiveDocument.FormFields("BKnonint_bearin35").Select
End If
End With
Call ThisDocument.protectDocument
Unload Me
Exit Sub
errhandler:
MsgBox "in button click " & Err.Description
End Sub
Sub AddControlsToTable(intRowNumberInDoc)
Dim strFormula As String
On Error GoTo errhandler
With ActiveDocument.Bookmarks("BKRevenueReport").Range.Tables(1)
.Rows(intRowNumberInDoc).Select
Selection.Rows(1).Cells(1).Range.Select
Call mdlRevenue.addaFormField(Selection.Range, True, "", wdRegularText, "", "")
' this is where I changed True from false
Selection.Rows(1).Cells(2).Range.Select
Call mdlRevenue.addaFormField(Selection.Range, False, "", wdRegularText, "", "")
Selection.Rows(1).Cells(6).Range.Select
Call mdlRevenue.addaFormField(Selection.Range, True, "ChangeCalculate", wdNumberText, "", "#,##0.00;($#,##0.00)")
Selection.Rows(1).Cells(8).Range.Select
Call mdlRevenue.addaFormField(Selection.Range, True, "ChangeCalculate", wdNumberText, "1", "#,##0;(#,##0)")
Selection.Rows(1).Cells(9).Range.Select
strFormula = "=(e" & intRowNumberInDoc & " *h" & intRowNumberInDoc & ")*12"
Call mdlRevenue.addaField(Selection.Range, strFormula, 9)
Selection.Rows(1).Cells(10).Range.Select
strFormula = "=i" & intRowNumberInDoc & "-(g" & intRowNumberInDoc & ")*12"
Call mdlRevenue.addaField(Selection.Range, strFormula, 10)
Selection.Rows(1).Cells(11).Range.Select
Call mdlRevenue.addaFormField(Selection.Range, True, "", wdRegularText, "No", "")
End With
Exit Sub
errhandler:
MsgBox "in addcontrols to table " & Err.Description
End Sub
Function calculateRowNumber()
Dim aRange As Range
With ActiveDocument.Bookmarks("BKRevenueReport").Range.Tables(1)
Set aRange = ActiveDocument.Range _
(Start:=.Rows(1).Range.Start, _
End:=Selection.Range.End)
aRange.Select
calculateRowNumber = aRange.Rows.Count
End With
End Function
Function calculateRowNumberInData(strresult As String)
Dim aRange As Range
Dim strDataResult As String
With Documents("Table.doc").Tables(1)
For i = 2 To .Rows.Count
strDataResult = .Cell(i, 2).Range.Text
strDataResult = Left(strDataResult, Len(strDataResult) - 1)
If InStr(strresult, strDataResult) Then
calculateRowNumberInData = i
Exit For
End If
Next i
End With
End Function
Sub populateFields(intRowTable1 As Integer, intRowTable2 As Integer, strDoc1 As String, strDoc2 As String)
Dim aTable1 As Table
Dim aTable2 As Table
Set aTable1 = Documents(strDoc1).Bookmarks("BKRevenueReport").Range.Tables(1)
Set aTable2 = Documents(strDoc2).Tables(1)
Dim i As Integer
For i = 3 To ActiveDocument.Tables(1).Columns.Count
aTable1.Cell(intRowTable1, i).Range = _
Trim(Left(aTable2.Cell(intRowTable2, i).Range.Text, Len(aTable2.Cell(intRowTable2, i).Range.Text) - 1))
Next i
End Sub
Can anyone tell me what/where this code needs to be edited and how so that more than 44 lines of data can be added?
Thanking you in advance for any help you may have to offer.
Const DOCPATH As String = "C:\RBCTable"
Private Sub UserForm_Initialize()
Dim aRange1 As Range
Dim adoc1 As Document
Dim adoc2 As Document
Set adoc1 = ActiveDocument
Set aRange1 = ActiveDocument.Bookmarks("BKRevenueReport").Range.Tables(1).Range
Dim i As Integer
Dim blnOpen As Boolean
On Error GoTo errhandler
Application.ScreenUpdating = False
For i = 1 To Documents.Count
If Documents(i).Name = "Table.doc" Then
blnOpen = False
Exit For
Else
blnOpen = True
End If
Next i
If blnOpen = False Then
'do nothing doc already opened
Else
ChangeFileOpenDirectory DOCPATH
Documents.Open DOCPATH & "\Table.doc", _
addtoRecentFiles:=no, Visible:=no
End If
Set adoc2 = Documents("Table.doc")
With adoc2.Tables(1)
For i = 2 To .Rows.Count
Dim strresult As String
strresult = .Cell(i, 2).Range.Text
strresult = Left(strresult, Len(strresult) - 1)
Me.ListBox1.AddItem strresult
Next i
adoc1.Activate
End With
Dim j As Integer
With aRange1
For i = 2 To .Rows.Count - 1
strresult = .Rows(i).Cells(2).Range.FormFields(1).Result
For j = 0 To Me.ListBox1.ListCount - 1
If strresult = Me.ListBox1.List(j) Then
Me.ListBox1.Selected(j) = True
End If
Next j
Next i
End With
Application.ScreenUpdating = True
Application.ScreenRefresh
Exit Sub
errhandler:
MsgBox "in initialize " & Err.Description
End Sub
Private Sub CommandButton1_Click()
Dim intRownumindoc As Integer
Dim intrownumindata As Integer
Dim i As Integer
Dim j As Integer
Dim strDoc1 As String
Dim strDoc2 As String
Dim blnAdd As Boolean
On Error GoTo errhandler
strDoc1 = ActiveDocument.Name
Call ThisDocument.unprotectDocument
strDoc2 = "Table.doc"
With ActiveDocument.Bookmarks("BKRevenueReport").Range.Tables(1)
For i = 0 To Me.ListBox1.ListCount - 1
blnAdd = True
If Me.ListBox1.Selected(i) = True Then
For j = 2 To .Rows.Count - 1
If .Rows(j).Cells(2).Range.Fields(1).Result = Me.ListBox1.List(i) Then
'the row has already been added ' do not do anything
blnAdd = False
Exit For
End If
Next j
Select Case blnAdd
Case True
Documents(strDoc1).Activate
Call mdlRevenue.createNewRow
intRownumindoc = calculateRowNumber
Documents(strDoc2).Activate
intrownumindata = calculateRowNumberInData(Me.ListBox1.List(i))
Documents(strDoc1).Activate
Call populateFields(intRownumindoc, intrownumindata, strDoc1, strDoc2)
Documents(strDoc1).Tables(1).Rows(intRownumindoc).Range.Select
Call AddControlsToTable(intRownumindoc)
Selection.Rows(1).Cells(2).Range.FormFields(1).Result = Me.ListBox1.List(i)
End Select
Else
For j = 2 To .Rows.Count - 1
If .Rows(j).Cells(2).Range.Fields(1).Result = Me.ListBox1.List(i) Then
'rows was previously added to document but has now to be deleted
.Rows(j).Delete
Exit For
End If
Next j
End If
Next i
Dim intTotalRows As Integer
intTotalRows = .Rows.Count
.Rows(intTotalRows).Select
Selection.Fields.Update
End With
Documents("Table.doc").Close
Documents(strDoc1).Activate
With ActiveDocument.Bookmarks("BKRevenueReport").Range.Tables(1)
If .Rows.Count > 2 Then
.Rows(2).Cells(10).Range.FormFields(1).Select
Else
ActiveDocument.FormFields("BKnonint_bearin35").Select
End If
End With
Call ThisDocument.protectDocument
Unload Me
Exit Sub
errhandler:
MsgBox "in button click " & Err.Description
End Sub
Sub AddControlsToTable(intRowNumberInDoc)
Dim strFormula As String
On Error GoTo errhandler
With ActiveDocument.Bookmarks("BKRevenueReport").Range.Tables(1)
.Rows(intRowNumberInDoc).Select
Selection.Rows(1).Cells(1).Range.Select
Call mdlRevenue.addaFormField(Selection.Range, True, "", wdRegularText, "", "")
' this is where I changed True from false
Selection.Rows(1).Cells(2).Range.Select
Call mdlRevenue.addaFormField(Selection.Range, False, "", wdRegularText, "", "")
Selection.Rows(1).Cells(6).Range.Select
Call mdlRevenue.addaFormField(Selection.Range, True, "ChangeCalculate", wdNumberText, "", "#,##0.00;($#,##0.00)")
Selection.Rows(1).Cells(8).Range.Select
Call mdlRevenue.addaFormField(Selection.Range, True, "ChangeCalculate", wdNumberText, "1", "#,##0;(#,##0)")
Selection.Rows(1).Cells(9).Range.Select
strFormula = "=(e" & intRowNumberInDoc & " *h" & intRowNumberInDoc & ")*12"
Call mdlRevenue.addaField(Selection.Range, strFormula, 9)
Selection.Rows(1).Cells(10).Range.Select
strFormula = "=i" & intRowNumberInDoc & "-(g" & intRowNumberInDoc & ")*12"
Call mdlRevenue.addaField(Selection.Range, strFormula, 10)
Selection.Rows(1).Cells(11).Range.Select
Call mdlRevenue.addaFormField(Selection.Range, True, "", wdRegularText, "No", "")
End With
Exit Sub
errhandler:
MsgBox "in addcontrols to table " & Err.Description
End Sub
Function calculateRowNumber()
Dim aRange As Range
With ActiveDocument.Bookmarks("BKRevenueReport").Range.Tables(1)
Set aRange = ActiveDocument.Range _
(Start:=.Rows(1).Range.Start, _
End:=Selection.Range.End)
aRange.Select
calculateRowNumber = aRange.Rows.Count
End With
End Function
Function calculateRowNumberInData(strresult As String)
Dim aRange As Range
Dim strDataResult As String
With Documents("Table.doc").Tables(1)
For i = 2 To .Rows.Count
strDataResult = .Cell(i, 2).Range.Text
strDataResult = Left(strDataResult, Len(strDataResult) - 1)
If InStr(strresult, strDataResult) Then
calculateRowNumberInData = i
Exit For
End If
Next i
End With
End Function
Sub populateFields(intRowTable1 As Integer, intRowTable2 As Integer, strDoc1 As String, strDoc2 As String)
Dim aTable1 As Table
Dim aTable2 As Table
Set aTable1 = Documents(strDoc1).Bookmarks("BKRevenueReport").Range.Tables(1)
Set aTable2 = Documents(strDoc2).Tables(1)
Dim i As Integer
For i = 3 To ActiveDocument.Tables(1).Columns.Count
aTable1.Cell(intRowTable1, i).Range = _
Trim(Left(aTable2.Cell(intRowTable2, i).Range.Text, Len(aTable2.Cell(intRowTable2, i).Range.Text) - 1))
Next i
End Sub