' Set wrdTable1 = objDoc.Tables.Add(objDoc.Range, 20, 2)
Set wrdTable1 = objDoc.Tables.Add(Range:=objWord.Selection.Range, NumRows:=20, NumColumns:=2, _
DefaulttableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed)
wrdTable1.Borders.Enable = False
With wrdTable1.Rows(1)
.Cells(1).Range.Text = "Tele: ####"
.Cells(1).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
.Cells(2).Range.Text = "!##########"
.Cells(2).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
wrdTable1.Rows(2).Cells(2).Range.Text = "PIN- 9#####"
wrdTable1.Rows(3).Cells(2).Range.Text = "##########"
wrdTable1.Rows(20).Cells.Merge
wrdTable1.Rows(20).Cells(1).Range.Text = "2. It is under ref :-"
wrdTable1.Rows(20).Cells(1).Range.ParagraphFormat.Alignment = wdAlignParagraphJustify
wrdTable1.Range.InsertParagraphAfter
Set wrdTable2 = objDoc.Tables.Add(wrdTable1.Range.Next, ntotalRecords, ntotalColumns)
Dim intRow As Integer
Dim intCol As Integer
With wrdTable2
intCtr = 1: intRow = 1
While (Sheets("SummaryDVBan").Cells(intCtr, 11).FormulaR1C1 <> "")
For intCol = 1 To ntotalColumns
.cell(intRow, intCol).Range.InsertAfter Sheets("SummaryDVBan").Cells(intCtr, intCol + 10).FormulaR1C1
Next intCol
intCtr = intCtr + 1
intRow = intRow + 1
Wend
.Columns(1).SetWidth 40, wdAdjustFirstColumn
.Columns(2).SetWidth 120, wdAdjustFirstColumn
.Columns(3).SetWidth 60, wdAdjustFirstColumn
.Columns(4).SetWidth 90, wdAdjustFirstColumn
.Columns(5).SetWidth 65, wdAdjustFirstColumn
.Columns(6).SetWidth 60, wdAdjustFirstColumn
.Columns(7).SetWidth 90, wdAdjustFirstColumn
.Style = "Table Grid"
.Borders.Enable = True
.Rows(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Rows(1).Range.Bold = True
.Rows(1).HeadingFormat = True
.Range.ParagraphFormat.Alignment = wdAlignParagraphJustify
.Borders.InsideLineStyle = wdLineStyleSingle
End With
wrdTable2.Range.InsertParagraphAfter
Set wrdTable3 = objDoc.Tables.Add(wrdTable2.Range.Next, 7, 4) ' insert table 3
wrdTable3.Borders.Enable = False
w = wrdTable3.Rows(1).Cells(1).Width * 4
w1 = w * 0.26
For X = 1 To 7
With wrdTable3.Rows(X)
.Cells(1).Width = w1
.Cells(2).Width = w1
.Cells(3).Width = w1
.Cells(4).Width = w1
.Height = 16
End With
Next X
wrdTable3.Rows(1).Cells.Merge
wrdTable3.Rows(1).Cells(1).Range.Text = "3. The confirmation at the earliest pl."
wrdTable3.Rows(1).Cells(1).Range.ParagraphFormat.Alignment = wdAlignParagraphJustify
wrdTable3.Rows(1).Cells(1).Range.ParagraphFormat.LineSpacingRule = wdLineSpaceAtLeast
wrdTable3.Rows(1).Cells(1).Range.ParagraphFormat.LineSpacing = 18
With objDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range
.Text = "REQUEST REMINDER"
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Font.Bold = True
.Font.Name = "Arial"
.Font.Size = 12
.Font.Underline = wdUnderlineSingle
.InsertParagraphAfter
.ParagraphFormat.SpaceAfter = 12 ' twice the font size for 1 "blank line"
End With
End Sub
the above code adds three tables into the word document however, the output document is showing the first two tables as joint. Also the when the table2 is spilling over the next page the output word document has the first table being repeated again on the second page. the first table is also being shown with gridlines despite the gridlines set as false.
In the output first and third table is to be without gridlines. first and second table needs to have space between them. the second table is with gridlines. and the first table is not required to repeat itself
Use the document to insert the paragraph and a section break, and also use the document to reference the range to add the next table
objDoc.Paragraphs.Last.Range.InsertParagraphAfter
objDoc.Paragraphs.Last.Range.InsertBreak Type:=wdSectionBreakContinuous
Dim rng As Range
Set rng = objDoc.Range(objDoc.Paragraphs.Last.Range.Start, objDoc.Paragraphs.Last.Range.End)
Set wrdTable2 = objDoc.Tables.Add(rng, ntotalrecords, ntotalColumns)
Dim intRow As Integer
Dim intCol As Integer
Related
A table is being inserted from Excel to Word.It populates the table by rows and columns. Vba opens my file in word .draw and fill the table in my word document. The main issue i am having is that despite i have inserted a bookmark in my word document the table is not inserted at the bookmark's place. My codes are as follows :-
Sub CreateTableInWord()
Dim objWord As Object, objDoc As Object, objTbl As Object, objRow As Object
Dim objCol As Object, colSets As Long, numMonths As Long, i As Long, n As Long, c As Long
Dim amt, dtStart, tblRows As Long, tblCols As Long, rw As Long, col As Long
numMonths = Range("A1").Value
amt = Range("B1").Value
dtStart = Range("C1").Value
colSets = Range("D1").Value 'how many sets of columns ?
tblRows = 1 + Application.Ceiling(numMonths / colSets, 1) 'how many table rows?
tblCols = colSets * 3 'how many table cols?
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
'Set objDoc = objWord.Documents.Add
Set objDoc = objWord.Documents.Open("C:\Users\rakesh\Desktop\mailmerge\lease2.docx")
Dim oRange As Object
Set oRange = objDoc.Bookmarks("RS").Range
Set objTbl = objDoc.Tables.Add(Range:=objDoc.Paragraphs(1).Range, _
NumRows:=tblRows, NumColumns:=tblCols)
c = 0
For n = 1 To colSets
objTbl.Cell(1, c + 1).Range.Text = "Instal No"
objTbl.Cell(1, c + 1).Range.Bold = True
objTbl.Cell(1, c + 2).Range.Text = "Amt(Rs)"
objTbl.Cell(1, c + 2).Range.Bold = True
objTbl.Cell(1, c + 3).Range.Text = "Due Date"
objTbl.Cell(1, c + 3).Range.Bold = True
c = c + 3
Next n
objTbl.Range.ParagraphFormat.Alignment = 1 ' wdAlignParagraphCenter
rw = 2
col = 0
For i = 1 To numMonths
'rw = 1 + Application.Ceiling(i / colSets, 1) 'fill across and then down
rw = IIf(i Mod (tblRows - 1) = 1, 2, rw + 1) 'fill down then across
objTbl.Cell(rw, col + 1).Range.Text = i
objTbl.Cell(rw, col + 2).Range.Text = amt
objTbl.Cell(rw, col + 3).Range.Text = Format(DateAdd("m", i - 1, dtStart), "dd/mm/yyyy")
'col = IIf(i Mod colSets = 0, 0, col + 3) 'fill across and then down
col = IIf(i Mod (tblRows - 1) = 0, col + 3, col) 'fill down and then across
Next i
End Sub
«how to autofit the table column width i have tried objTbl.Range.EntireColumn.AutoFit i's not working»
Word is not Excel! Word has no such table property as EntireColumn. You really should spend some time learning Word's properties and methods. Try:
With objDoc
Set objTbl = .Tables.Add(Range:=.Bookmarks("RS").Range, _
NumRows:=tblRows, NumColumns:=tblCols, _
DefaultTableBehavior:=wdWord9TableBehavior, _
AutofitBehaviour:=wdAutoFitContent)
End With
or:
objTbl.Columns.AutoFit
You need to use oRange when adding the table:
Dim oRange As Object
Set oRange = objDoc.Bookmarks("RS").Range
Set objTbl = objDoc.Tables.Add(Range:=oRange , _
NumRows:=tblRows, NumColumns:=tblCols)
You don't even need oRange, let alone use it when adding the table:
With objDoc
Set objTbl = .Tables.Add(Range:=.Bookmarks("RS").Range, _
NumRows:=tblRows, NumColumns:=tblCols)
End With
Hi i am making a organisational hierarchy chart and i want to have a textbox below each nodes. What i did until now was to retrieve the data and plot out the hierarchy. But how do i add textbox under them? I have to add 2 textboxes below each nodes. Any help will be appreciated!
Code:
Option Explicit
Sub OrgChart()
Dim ogSALayout As SmartArtLayout
Dim QNodes As SmartArtNodes
Dim QNode As SmartArtNode
Dim ogShp As Shape
Dim shp As Shape
Dim t As Long
Dim i As Long
Dim r As Long
For Each shp In ActiveSheet.Shapes
If shp.Type = msoSmartArt Then: shp.Delete
Next shp
Set ogSALayout = Application.SmartArtLayouts( _
"urn:microsoft.com/office/officeart/2009/3/layout/HorizontalOrganizationChart" _
)
Set ogShp = ActiveSheet.Shapes.AddSmartArt(ogSALayout, 630, 36, 1000, 1000)
Set QNodes = ogShp.SmartArt.AllNodes
t = QNodes.Count
For i = 2 To t: ogShp.SmartArt.Nodes(1).Delete: Next i
Set QNode = QNodes(1)
If Range("D1").Value = "CONFIRM" Then
QNode.Shapes.Fill.ForeColor.RGB = RGB(255, 0, 0)
ElseIf Range("D1").Value = "PENDING" Then
QNode.Shapes.Fill.ForeColor.RGB = RGB(128, 128, 128)
ElseIf Range("D1").Value = "SUSPECTED" Then
QNode.Shapes.Fill.ForeColor.RGB = RGB(255, 255, 0)
ElseIf Range("D1").Value = "NO" Then
QNode.Shapes.Fill.ForeColor.RGB = RGB(0, 255, 0)
End If
With QNode.TextFrame2.TextRange
.Text = Range("B1").Value
.Font.Fill.ForeColor.RGB = vbBlack
.Font.Size = 12
.Font.Bold = True
End With
With QNode.Shapes.AddTextbox(msoTextOrientationHorizontal, _
100, 100, 200, 50) _
.TextFrame.Characters.Text = "Test Box"
End With
r = 1
Call AddChildren(QNode, r)
ogShp.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
End Sub
Sub AddChildren(ByVal QParent As SmartArtNode, ByVal r As Long)
Dim QChild As SmartArtNode
Dim Level As Long
Dim s As Long
Const MyCol As String = "C"
Level = Range(MyCol & r).Value
s = r + 1
Do While Range(MyCol & s).Value > Level
If Range(MyCol & s).Value = Level + 1 Then
Set QChild = QParent.AddNode(msoSmartArtNodeBelow)
If Range("D" & s).Value = "CONFIRM" Then
QChild.Shapes.Fill.ForeColor.RGB = RGB(255, 0, 0)
ElseIf Range("D" & s).Value = "PENDING" Then
QChild.Shapes.Fill.ForeColor.RGB = RGB(128, 128, 128)
ElseIf Range("D" & s).Value = "SUSPECTED" Then
QChild.Shapes.Fill.ForeColor.RGB = RGB(255, 255, 0)
ElseIf Range("D" & s).Value = "NO" Then
QChild.Shapes.Fill.ForeColor.RGB = RGB(0, 255, 0)
End If
With QChild.TextFrame2.TextRange
.Text = Range("B" & s).Value
.Font.Fill.ForeColor.RGB = vbBlack
.Font.Size = 12
End With
Call AddChildren(QChild, s)
End If
s = s + 1
Loop
End Sub
This is what it looks like now:
Edit: Added screenshot of data layout.
Adding a textbox under a node would mean that you would have to move the node up to make room for the textbox. As far as I know, it's not possible to move the nodes using VBA.
As a workaround, you could create another node under each node and format it as a textbox.
The outcome would look something like this:
To do this, I would first remove this from OrgChart
With QNode.Shapes.AddTextbox(msoTextOrientationHorizontal, _
100, 100, 200, 50) _
.TextFrame.Characters.Text = "Test Box"
End With
And replace it with:
Dim PseudoTxtBox As SmartArtNode
Set PseudoTxtBox = QNode.AddNode(msoSmartArtNodeAfter) 'Pseudo text box
'Add some text to the textbox
With PseudoTxtBox.TextFrame2.TextRange
.Text = "Some Text"
.Font.Fill.ForeColor.RGB = vbBlack
.Font.Size = 12
End With
'Make the textbox background transparent
PseudoTxtBox.Shapes.Fill.Transparency = 1
Then I would insert the following code right after adding the node in AddChildren :
Dim PseudoTxtBox As SmartArtNode
Set PseudoTxtBox = QChild.AddNode(msoSmartArtNodeAfter) 'Pseudo text box
'Add some text to the textbox
With PseudoTxtBox.TextFrame2.TextRange
.Text = "Some Text"
.Font.Fill.ForeColor.RGB = vbBlack
.Font.Size = 12
End With
'Make the textbox background transparent
PseudoTxtBox.Shapes.Fill.Transparency = 1
'Get the parent shape
Dim mshp As Shape
Dim tempObject As Object
Set tempObject = QChild.Parent
Do While TypeName(tempObject) <> "Shape"
Set tempObject = tempObject.Parent
Loop
Set mshp = tempObject
'Set the corresponding connector (line) to be transparent.
mshp.GroupItems(Level).Line.Transparency = 1
I'm trying to populate a form from another table. I have an identifier (formNumber). The loop's purpose is the find all the rows in the table with the same formNumber, then list the details in a form.
Problem encountered is in the fields using startTableRow, startSubdesc1, startSubdesc2, startRemark. I dont know when they are all repeating the same values, that have already been inputted. An item should only appear once.
Dim wsCurrent As Worksheet, _
loTable1 As ListObject, _
lcColumns As ListColumns, _
lrCurrent As ListRow
Set wsCurrent = Worksheets("Expenses")
Set loTable1 = wsCurrent.ListObjects("Expenses")
Set lcColumns = loTable1.ListColumns
'Loop through and find new entries which haven't been form'd yet
For x = 1 To loTable1.ListRows.Count
Set lrCurrent = loTable1.ListRows(x)
If lrCurrent.Range(1, lcColumns("form sent?").Index) = "" And _
lrCurrent.Range(1, lcColumns("form #").Index) <> "" Then
formNumber = lrCurrent.Range(1, lcColumns("form #").Index).Value
'Set first lines on the form
Worksheets("form").Cells(10, 10).Value = formNumber
'Loop through the Expense sheet and as long as the form number doesn't _
'change, write it to the table on the form
startTableRow = 20
startSubdesc1 = 21
startSubdesc2 = 22
startRemark = 54
Do While lrCurrent.Range(1, lcColumns("form #").Index).Value = formNumber
expensesDate = lrCurrent.Range(1, lcColumns("Date").Index).Value
expensesItem = lrCurrent.Range(1, lcColumns("Description").Index).Value
expensesSubdesc1 = lrCurrent.Range(1, lcColumns("Sub-description 1").Index).Value
expensesSubdesc2 = lrCurrent.Range(1, lcColumns("Sub-description 2").Index).Value
expensesRemarks = lrCurrent.Range(1, lcColumns("Remarks").Index).Value
**Worksheets("form").Cells(startTableRow, 5) = expensesItem
Worksheets("form").Cells(startSubdesc1, 5) = expensesSubdesc1
Worksheets("form").Cells(startSubdesc2, 5) = expensesSubdesc2
Worksheets("form").Cells(startRemark, 3) = expensesRemarks
Worksheets("form").Cells(12, 10) = expensesDate**
lrCurrent.Range(1, lcColumns("form sent?").Index).Value = "Yes"
x = x + 1
startTableRow = startTableRow + 3
startSubdesc1 = startSubdesc1 + 3
startSubdesc2 = startSubdesc2 + 3
startRemark = startRemark + 1
Loop
'Need to subtract one from x to loop through the row again
x = x - 1
'Clear data in table on form
For t = 20 To 45
Worksheets("form").Cells(t, 3).Value = ""
Worksheets("form").Cells(t, 5).Value = ""
Next t
'Clear data in REMARK on form
For r = 54 To 57
Worksheets("form").Cells(r, 3).Value = ""
Next r
End If
Next x
End Sub
End Sub
The problem with your code is in the while loop the lrCurrent does not change. after x = x +1 you need to set
lrCurrent = loTable1.ListRows(x) IF x <= loTable1.ListRows.Count
Also then need to protect against running past the end of table by adding another condition
And x <= loTable1.ListRows.Count
to the Do While line at the start.
Here is an example with fewer variables by using .offset
Sub FillForm()
Dim wb As Workbook, ws As Worksheet, wsForm As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("Expenses")
Set wsForm = wb.Sheets("form")
Dim tbl As ListObject
Set tbl = ws.ListObjects("Expenses")
' create look up for column names
Dim ColNum As New Collection
Dim cell As Range, ix As Integer
For Each cell In tbl.HeaderRowRange
ix = ix + 1
ColNum.add ix, cell.Value
Debug.Print cell.Value
Next
' scan table for not sent items
Dim sFormNo As String, rec As Range
Dim iCount As Integer ' count of lnes with same form no
Dim bSearch As Boolean, iSearch As Integer
Dim iRow As Integer
bSearch = False ' search for matching form no
With tbl
For iRow = 1 To .ListRows.Count
Set rec = .ListRows(iRow).Range
If rec(ColNum("form #")) <> "" _
And rec(ColNum("form sent?")) = "" Then
sFormNo = rec(1)
wsForm.Range("J10") = rec(ColNum("form #"))
wsForm.Range("J12") = rec(ColNum("Date"))
bSearch = True
End If
' search rest of table for more records
If bSearch Then
'Clear data in table on form
'wsForm.Range("C20:C45").ClearContents ' required ?
wsForm.Range("E20:C45").ClearContents
wsForm.Range("C54:C57").ClearContents
iCount = 0
' search from existing row down to end
For iSearch = iRow To .ListRows.Count
Set rec = .ListRows(iSearch).Range
' check match
If rec(ColNum("form #")) = sFormNo _
And rec(ColNum("form sent?")) = "" Then
' fill in form
With wsForm.Range("E20").Offset(3 * iCount, 0)
.Offset(0, 0) = rec(ColNum("Description"))
.Offset(1, 0) = rec(ColNum("Sub-description 1"))
.Offset(2, 0) = rec(ColNum("Sub-Description 2"))
End With
wsForm.Range("C54").Offset(iCount, 0) = rec(ColNum("Remarks"))
' update form sent column
rec(ColNum("form sent?")) = "Yes"
iCount = iCount + 1
Debug.Print "Search for " & sFormNo, rec(ColNum("form #")), iCount, iSearch
End If
Next
wsForm.Activate
wsForm.Range("A20").Select
MsgBox iCount & " lines added", vbInformation, "Completed " & sFormNo
bSearch = False
End If
Next
End With
MsgBox "Ended", vbInformation
End Sub
The problem with the error bars seems to be resolved, but now I am gettng a error 5. The error line is:
ActiveChart.SeriesCollection(1).ApplyDataLabels AutoText:=False, LegendKey:=False, ShowSeriesName:=False, ShowCategoryName:=False, ShowValue:=True, _
ShowPercentage:=False, ShowBubbleSize:=False
'resize chart
WS.ChartObjects(1).Width = 500
WS.ChartObjects(1).Height = chartmultipl * (rowcnt - 1 - minscale)
WS.ChartObjects(1).Left = chartleftpos
WS.ChartObjects(1).Top = 70
'Rescale values to positions in chart so that labels can be succesfully moved
minchar = ActiveChart.Axes(xlCategory).MinimumScale
maxchar = ActiveChart.Axes(xlCategory).MaximumScale
midchar = (maxchar + minchar) / 2
'datalabels
ActiveChart.SeriesCollection(1).ApplyDataLabels AutoText:=False, LegendKey:=False, ShowSeriesName:=False, ShowCategoryName:=False, ShowValue:=True, _
ShowPercentage:=False, ShowBubbleSize:=False
For i = 1 To rowcnt - 1
If WS.Cells(i + 1, labelcol) <> "" Then
With ActiveChart.SeriesCollection(1).Points(i).DataLabel
.Characters.Text = Left(WS.Cells(i + 1, labelcol).Value, 28)
.AutoScaleFont = False
With .Characters(Start:=1, Length:=100).Font
.Name = "Arial"
If WS.Cells(i + 1, labelcol).Font.Italic = True Then
.FontStyle = "Italic"
ElseIf WS.Cells(i + 1, labelcol).Font.Bold = True Or Not ptype Then
.FontStyle = "Bold"
Else
.FontStyle = "Normal"
End If
.Size = labelsize
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
'move labels wherever there is enough space to display them or to the beginning of the graph
If ptype Then
textsize = Application.WorksheetFunction.Min(Len(WS.Cells(i + 1, labelcol).Value), 28)
If WS.Cells(i + 1, int1).Value <= midchar Then
.Left = 15 + Round(ActiveChart.PlotArea.Width * (WS.Cells(i + 1, 6).Value - minchar) / (maxchar - minchar))
Else
.Left = -textsize * 3 + Round(ActiveChart.PlotArea.Width * (WS.Cells(i + 1, 5).Value - minchar) / (maxchar - minchar))
End If
Else
.Left = 20
End If
End With
End If
Next i
'if it's an outcome graph use set square sizes, if a final MA graph use study weights
If Not ptype Then
For i = 1 To resultcount
With ActiveChart.SeriesCollection(1).Points(i)
.MarkerSize = Round(sqsize(i), 0)
End With
Next i
End If
'send chart to back for future merging
WS.ChartObjects(1).SendToBack
'ActiveChart.ChartArea.Select
'Selection.ShapeRange.ZOrder msoSendToBack
'deselect graph so that I can add the rest of the shapes but first save things that are needed
minsc = ActiveChart.Axes(xlCategory).MinimumScale
maxsc = ActiveChart.Axes(xlCategory).MaximumScale
WS.Range("A1").Select
'if it is the final scatterplot add the diamonds
If Not ptype Then
Dim plarealeft, plarearight As Double
Dim dheight, incrh As Double
Dim origleft, origlength, transleft As Double
Dim diampos, diamlength As Double
Dim grtop As Double
'left and right edge of plot area in pixels
plarealeft = 371
plarearight = 827
'diamond statistics
dheight = 10
'vertical alignment of diamonds - increment from one to another
incrh = WS.ChartObjects(1).Height / ((rowcnt - 1) - minscale + 2)
'top of the graph
grtop = WS.ChartObjects(1).Top
'get all info in tables so that I can use in loops
mu(1) = fe_mu
mu(2) = dl_mu
mu(3) = ml_mu
mu(4) = pl_mu
mu(5) = T_mu
mvar(1) = fe_var
mvar(2) = dl_var
mvar(3) = ml_var
mvar(4) = pl_var
mvar(5) = T_var
For i = 1 To 4
tmargin(i) = 1.96
Next i
tmargin(5) = Excel.WorksheetFunction.TInv(0.05, resultcount - 1)
tlabel(1) = "FE"
tlabel(2) = "DL"
tlabel(3) = "ML"
tlabel(4) = "PL"
tlabel(5) = "T"
'go through all 5 diamonds
For i = 1 To 5
'original length and far left position
origleft = mu(i) - tmargin(i) * (mvar(i) ^ (1 / 2))
origlength = 2 * tmargin(i) * (mvar(i) ^ (1 / 2))
'transform to [0,1] scale
transleft = (origleft - minsc) / (maxsc - minsc)
'transform to points
diampos = plarealeft + (plarearight - plarealeft) * transleft + 1
diamlength = (plarearight - plarealeft) * origlength / (maxsc - minsc)
ActiveSheet.Shapes.AddShape(msoShapeDiamond, diampos, grtop + (rowcnt - 1.5 + i + 1) * incrh - dheight / 2, diamlength, dheight).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 0, 0)
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, diampos + diamlength + 10, grtop + (rowcnt - 1.5 + i + 1) * incrh - dheight / 2, 20, 12).Select
Selection.Characters.Text = tlabel(i)
With Selection.ShapeRange
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
End With
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 9
End With
Next i
End If
'add text files with study information
If ptype Then
tboxend = rowcnt * 10
tboxstep = (tboxend - 80) / (rowcnt - 2)
For i = 2 To rowcnt
If (WS.Cells(i, 1).Value <> "" And WS.Cells(i - 1, 1).Value = "") Or i = 2 Then
'find how many outcomes there are in each study to better align the text boxes
j = i
Do
j = j + 1
Loop Until WS.Cells(j, 1).Value = ""
cntr = j - i
'create textbox
tboxpos = tboxend - (i - 2) * tboxstep - (cntr - 1) * tboxstep / 2
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 500, tboxpos, 60, 25).Select
Selection.Characters.Text = WS.Cells(i, 1).Value
With Selection.ShapeRange
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
End With
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End If
Next i
End If
'create a list with all the shapes that need to be selected and group them
j = 0
For Each Sh In WS.Shapes
If Not Left(Sh.Name, 7) = "Comment" Then
j = j + 1
ReDim Preserve sharray(j)
sharray(j) = Sh.Name
End If
Next Sh
WS.Shapes.Range(sharray).Group
'deselect shape
WS.Range("A1").Select
Application.ScreenUpdating = True
End Sub
First thing to do, to help track down the error is to define all your variables properly.
Example: your first line
Dim rowcnt, textsize, cntr, labeltop As Integer
is actually the same as this:
Dim rowcnt as Variant
Dim textsize as Variant
dim cntr as Variant
dim labeltop As Integer
doing this may bring up other errors that can help you track down what is causing the line to fail
Declare Option Explicit at the top of your code, it will help you write better code by forcing you to declare all variables and help you identify bugs more easily.
This is probably causing your Invalid Call or Argument error:
'get the last row of data
rowcnt = LASTINCOLUMN2(6, k)
Unless you have a custom function called LASTINCOLUMN2 that you didn't post?
To get the last row use:
rowcnt = WS.Range("B" & Rows.Count).End(xlUp).Row
Declare rowcnt as Long not an integer.
You need to define:
ptype
resultcount
vareffects
Edit: I am still running through your code and identifying many unidentified subs/functions. Is there a second part to the code?
I tried Sum, CountIf, Dsum, SumProduct
I have a Userform with a ComboBox "History_Select_Debtor". The RowSource for the ComboBox is "Debtor_list_Debtors" - A Dynamic Named Range on WorkSheet "DebtorList". It consists of Customer Names from A2:A24 but will grow eventually.
The UserForm also Has a Textbox for Total Items Purchased Named "txtPurchased".
With each Transaction a Record is saved on Worksheet "InvoiceList" which consists of 7 Columns.
Each of these Columns have Dynamic Named Ranges
A = "Debtor" (Invoice_list_Debtor)
B = "Item" (Invoice_list_Item)
C = "Price" (Invoice_list_Price)
D = "Date" (Invoice_list_Date)
E = "Time" (Invoice_list_Time)
F = "Balance" (Invoice_list_Balance)
G = "Payed" (InvoiceList_Payed)
The Record Saved in the Item Column is Text;
"Payed Balance","Added Balance","Quarter Item","Half Item","1 Item" - "10 Items"
I need to, "Based on the combo selection (History_Select_Debtor)", Reference that Particilar Debtor with "InvoiceList", sum up the total Number of Purchases and display that Value in "txtPurchased".
I need a specific Value to be assigned to each Item e.g. "Quarter Item" = 0.25 or "5 Item = 5".
If as an example "Adrian" has 7 Transactions recorded on InvoiceList
Added Balance
Quarter Item
Half Item
Quarter Item
10 Items
4 Items
Payed Balance
The Value to be displayed in "txtPurchased" would be "15".
I've a Macro that sums up the total Purchases;
It sums up the Total Row rather than just whichever Debtor is Selected in "History_Select_Debtor"
'-------Total Transactions----------------------------------------------------------------------
Set ws = Worksheets("DebtorList")
With Me
'Starting point of lookup data
Rw = .History_Select_Debtor.ListIndex + 2
History_Select_Debtor.List = Range("Debtor_list_Debtors").Value
txtTransactions.Value = Application.CountIf(Range("Invoice_list_Debtor"), History_Select_Debtor)
End With
'-----------------------------------------------------------------------------------------------
Another Macro I've made which also won't work;
=SUM(IF(Invoice_list_Item="Quarter Item",0.25,0)+IF(Invoice_list_Item="Half Item",0.5,0)+IF(Invoice_list_Item="1 Item",1,0)+IF(Invoice_list_Item="2 Items",2,0)+IF(Invoice_list_Item="3 Items",3,0)+IF(Invoice_list_Item="4 Items",4,0)+IF(Invoice_list_Item="5 Items",5,0)+IF(Invoice_list_Item="10 Items",10,0))
The Issue with this one is that given I use the Invoice_list_Debtor as the RowSource for my ComboBox I end up with over 170 duplicate Names.
Here is the Source Code to the Page I need to code to work on;
Public ListTable As Long
Private Sub UserForm_Initialize()
History_Select_Debtor.List = Range("Debtor_list_Debtors").Value
History_Select_Debtor = ""
Label6.Visible = False
Label7.Visible = False
Label8.Visible = False
Label9.Visible = False
Label10.Visible = False
Label11.Visible = False
Label12.Visible = False
Dim ws As Worksheet
Set ws = Worksheets("InvoiceList")
ListTable = ws.Range("A65536").End(xlUp).Row
Me.ListBox1.List = Range("A2:G" & ListTable).Value
Me.ListBox1.Clear
Me.ListBox1.ColumnWidths = "50;80;70;100;80;80;80"
'-----------Listview--------------------------------------------------------------------------------------------------------------
'Dim ws As Worksheet
'Dim lngRow As Long
'Dim lvwItem As ListItem
'Dim lngEndCol As Long
'Dim lngCol As Long
'Dim lngEndRow As Long
'Dim lngItemIndex As Long
'Dim blnHeaders() As Boolean
'Dim Rw As Long
'Set ws = Worksheets("InvoiceList")
'lngEndCol = ws.Range("A1").End(xlToRight).Column
'lngEndRow = ws.Range("A1").End(xlDown).Row
'ListView1.Gridlines = True
'lngRow = 1
'With ListView1
'.View = lvwReport
'For lngCol = 1 To lngEndCol
'.ColumnHeaders.Add , , ws.Cells(lngRow, lngCol).Text, ws.Columns(lngCol).ColumnWidth + 59.6
'.BackColor = vbBlack
'Next
'For lngRow = 2 To lngEndRow
'lngCol = 1
'lngItemIndex = 0
'Set lvwItem = .ListItems.Add(, , (ws.Cells(lngRow, lngCol).Text))
'For lngCol = 2 To lngEndCol
'lngItemIndex = lngItemIndex + 1
'lvwItem.SubItems(lngItemIndex) = Format(ws.Cells(lngRow, lngCol).Text, ws.Cells(lngRow, lngCol).NumberFormat) 'Adds Value from Current Row and Column 1
'Next
'Next
'.TextBackground = lvwTransparent
'End With
'-----------Listview--------------------------------------------------------------------------------------------------------------
'-----------ChartSpace---------------------------------------------------
Dim ChtSpc As OWC11.ChartSpace
Dim cht As OWC11.ChChart
Dim Sps As OWC11.Spreadsheet
Dim owcChart As OWC11.ChartSpace
Dim Balance As String
Balance = Range("B1").Value
Set owcChart = Me.ChartSpace1
Set ChtSpc = Me.ChartSpace1
Set Sps = Me.Spreadsheet1
Set ws = ThisWorkbook.Worksheets("DebtorList") ' change to you worksheet name
Sps.Range("A1:B100") = ws.Range("A1:B100").Value ' Set worksheet range to sheet control range
Set ChtSpc.DataSource = Sps ' set sheet control as chart control source
Set cht = ChtSpc.Charts.Add ' Add blank chart
With cht ' Set data for chart
.SetData chDimCategories, 0, "A2:A25" ' change to your category range
.SeriesCollection(0).SetData chDimValues, 0, "B2:B25" ' change to your series 1 range
'.PlotArea.FlipHorizontal
'.PlotArea.FlipVertical
'.PlotArea.RotateClockwise
'.SeriesCollection.Add
'.SeriesCollection(1).SetData chDimValues, 0, "A1:A24" ' change to your series 2 range
'By changing the layout we can control how the charts are presented
'inside the Chart space.
.Interior.Color = RGB(0, 0, 0)
.Border.Color = vbWhite
.Border.Weight = Thick
'.Type = chChartTypeColumn3D
'.Type = chChartTypeAreaStacked
End With
Me.Spreadsheet1.Visible = False ' hide the sheet control
'Set up the charts and manipulate some of their properties.
With owcChart.Charts(0)
'The data reference must be of the datatype string.
'The last parameter specify if each row represent a serie or not.
'.HasTitle = True
With .PlotArea
.Interior.Color = RGB(0, 0, 0)
'.Border.Color = RGB(255, 255, 255)
'.Border.DashStyle = chLineSolid
'.Border.Weight = Thick
End With
'With .Title
'.Caption = Balance
'.Font.Name = "Verdana"
'.Font.Size = 10
'.Font.Bold = True
'.Font.Color = RGB(50, 205, 50)
'End With
With .Axes(0).Font
.Name = "Verdana"
.Size = 8
'.Bold = True
.Color = RGB(255, 255, 255)
End With
With .Axes(1).Font
.Name = "Verdana"
.Size = 8
'.Bold = True
.Color = RGB(255, 255, 255)
End With
'With .Axes(0).MinorGridlines
'.Line.Color = RGB(255, 255, 255)
'End With
'With .Axes(0).MajorGridlines
'.Line.Color = RGB(255, 255, 255)
'End With
'With .Axes(1).MinorGridlines
'.Line.Color = RGB(255, 255, 255)
'End With
'With .Axes(1).MajorGridlines
'.Line.Color = RGB(255, 255, 255)
'End With
With .SeriesCollection(0)
'.Border.Color = RGB(255, 255, 255)
.Interior.Color = vbGreen
.Caption = Balance
.Line.Color = RGB(255, 255, 255)
End With
'With .SeriesCollection(1)
'.Interior.Color = vbBlue
'.Caption = Balance
'End With
'.HasLegend = True
'With .Legend
'.Position = chLegendPositionBottom
'.Border.Color = vbWhite
'.LegendEntries(2).Visible = False
'End With
End With
'------------------------------------------------------------------------
End Sub
Private Sub cmdClose_History_Click()
Unload Me
frmMenu.Show
End Sub
Private Sub History_Select_Debtor_Change()
'--------Total Purchased-----------------------------------------------
'Worksheets("InvoiceList").Rows(1).AutoFilter Field:=1, Criteria1:="=" & Me.History_Select_Debtor
'Me.txtPurchased = Worksheets("Summary").[C2] 'the cell containing the SUBTOTAL
'-------------------------------------------------------
Label6.Visible = True
Label7.Visible = True
Label8.Visible = True
Label9.Visible = True
Label10.Visible = True
Label11.Visible = True
Label12.Visible = True
FilterList 0, Me.History_Select_Debtor.Text
Me.cmdClose_History.SetFocus
Dim ws As Worksheet
Dim Rw As Long
Set ws = Worksheets("DebtorList")
'Get row based on ComboBox ListIndex
With Me
'Starting point of lookup data
Rw = .History_Select_Debtor.ListIndex + 2
'Data to be displayed based on selection
txtBalance.Value = FormatCurrency(Expression:=ws.Cells(Rw, 2).Value, _
NumDigitsAfterDecimal:=2)
End With
'-------Total Transactions----------------------------------------------------------------------------------------------------------------------
Set ws = Worksheets("DebtorList")
With Me
'Starting point of lookup data
Rw = .History_Select_Debtor.ListIndex + 2
History_Select_Debtor.List = Range("Debtor_list_Debtors").Value
txtTransactions.Value = Application.CountIf(Range("Invoice_list_Debtor"), History_Select_Debtor)
End With
'-------Total Payed------------------------------------------------------------------------------------------------------------------------------
txtPayed.Value = FormatCurrency(Expression:=Application.SumIf(Range("Invoice_list_Debtor"), _
History_Select_Debtor.Value, Range("Invoice_list_Price")), _
NumDigitsAfterDecimal:=2)
End Sub
Private Sub UserForm_QueryClose _
(Cancel As Integer, CloseMode As Integer)
' Prevents use of the Close button
If CloseMode = vbFormControlMenu Then
Cancel = True
End If
End Sub
Private Sub FilterList(iCtrl As Long, sText As String)
Dim iRow As Long
Dim ws As Worksheet
Dim sCrit As String
sCrit = "*" & UCase(sText) & "*"
Set ws = Worksheets("InvoiceList")
With Me.ListBox1
ListTable = ws.Range("A65536").End(xlUp).Row
.List = ws.Range("A2:G" & ListTable).Value
For iRow = .ListCount - 1 To 0 Step -1
If Not UCase(.List(iRow, iCtrl)) Like sCrit Then
.RemoveItem iRow
End If
Next iRow
'Determine number of columns
.ColumnCount = 7
'Set column widths
.ColumnWidths = "50;80;70;100;80;80;80"
'Insert the range of data supplied
For x = 2 To 3 'loop the numeric columns - 3 to 4
For i = 0 To .ListCount - 1 'loop through the rows of columns 3 to 5
.List(i, x) = Format(.List(i, x), "$#,##")
Next i
Next x
For x = 5 To 6 'loop the numeric columns - 4 to 5
For i = 0 To .ListCount - 1 'loop through the rows of columns 3 to 5
.List(i, x) = Format(.List(i, x), "$#,##")
Next i
Next x
For x = 4 To 4 'loop the numeric columns - 3 to 4
For i = 0 To .ListCount - 1 'loop through the rows of columns 3 to 5
.List(i, x) = Format(.List(i, x), "[$-409]h:mm AM/PM;#")
Next i
Next x
End With
End Sub
There is more than one issue here I believe ...
To get the total number of invoiced items for a debtor you can
(auto)filter the InvoiceList for your current Debtor
display the sum of invoiced items using the =SUBTOTAL(109,InvoiceSheet!$F:$F) worksheet function (asuming the invoice sheet is named [InvoiceSheet] ;-) )
I would even suggest to have that =SUBTOTAL on a seperate sheet (Sheet2), so it's location is constant. Don't use ControlSource() on the text field in the dialog, but set Locked = True
You can set up Autofilter on [InvoiceSheet] once and use the Sub
Private Sub History_Select_Debtor_Change()
Worksheets("InvoiceSheet").Rows(1).AutoFilter field:=1, Criteria1:="=" & Me.History_Select_Debtor
Me.txtPurchased = Worksheets("Sheet2").[A1] 'the cell containing the SUBTOTAL
End Sub
to fire the filter and get the value of the SUBTOTAL formula back into the dialog.
For the transition of quantities from text to number I would suggest to create an extra sheet [QTYCode] looking like
A B ...
+------------+-----+----
1 |Text |Value|
2 |Quarter item| 0.25|
3 |Half item | 0.5|
4 |1 item | 1|
5 |2 item | 2|
6 |3 item | 3|
...
where column A (except header row) serves as RowSource() for the QTY selection box, and for each record you create in [InvoiceSheet] you save not only the selected QTYText, but as well an extra column containing a =VLOOKUP() formula that converts text into value (and base your =SUBTOTAL() on that new column - of course)
Hope that helps
Good luck - MikeD