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
Related
I have 2 excel sheets one is mapping and other is soneri. I want to increment the values of Column D in soneri sheet which was get by lookup function. What is the mistake in my code?
soneri sheet
mappingsheet
Outcome
Column D
Only first 2 rows are correct of my outcome else are wrong.
Expected Outcome
Below is my code
"WORKING CODE EDITED"
Sub ButtonClick()
Dim soneriWs As Worksheet, mappingWs As Worksheet
Dim sonerilastrow As Long, mappinglastrow As Long, i As Long
Dim datarange As Range, assetrange As Range, b As Range
Dim entry As Variant
Set soneriWs = ThisWorkbook.Worksheets("Soneri")
Set mappingWs = ThisWorkbook.Worksheets("Mapping")
sonerilastrow = soneriWs.Range("I" & soneriWs.Rows.Count).End(xlUp).Row
mappinglastrow = mappingWs.Range("A" & mappingWs.Rows.Count).End(xlUp).Row
Set datarange = mappingWs.Range("A2:B" & mappinglastrow)
Set assetrange = soneriWs.Range("I2:I" & sonerilastrow)
i = 0
For Each entry In assetrange
Set b = entry.Offset(, -5)
b = Application.WorksheetFunction.VLookup(entry, datarange, 2, False)
If entry = entry.Offset(-1) Then
i = i + 1
b = Left(b, Len(b) - 1) & (Right(b, 1) + i)
Else
i = 0
End If
Next entry
End Sub
Rows.Count returns that number of rows for the active sheet. Try changing these two lines:
sonerilastrow = soneriWs.Range("I" & Rows.Count).End(xlUp).Row
mappinglastrow = mappingWs.Range("A" & Rows.Count).End(xlUp).Row
To this:
sonerilastrow = soneriWs.Range("I" & soneriWs.Rows.Count).End(xlUp).Row
mappinglastrow = mappingWs.Range("A" & mappingWs.Rows.Count).End(xlUp).Row
Also remember to clear any errors that might occur, otherwise you can run into trouble. Insert this before the Sub returns:
If Err <> 0 Then Err.Clear
I see you removed your "on error" statement.
I would also recommend that you force variable decalarations, as I can see you use undeclared variables, which will also get you into trouble sooner or later. Insert this as the first line in all modules:
Option Explicit
EDIT:
Please post test data "as text" next time to help people help you.
Here is a solution.
I uncommented your if statement, as it seem to not update the first record.
Sub ButtonClick()
Dim soneriWs As Worksheet, mappingWs As Worksheet
Dim sonerilastrow As Long, mappinglastrow As Long, x As Long, b As String, c As String
Dim Dct As Object
Dim Cnt As Long
Dim CntTxt As String
Dim PreTxt As String
Dim Idx As Long
Dim datarange As Range
Set soneriWs = ThisWorkbook.Worksheets("Soneri")
Set mappingWs = ThisWorkbook.Worksheets("Mapping")
sonerilastrow = soneriWs.UsedRange.Rows.Count
mappinglastrow = mappingWs.UsedRange.Rows.Count
Set Dct = CreateObject("Scripting.Dictionary")
Set datarange = mappingWs.Range("A2:B" & mappinglastrow)
For x = 2 To sonerilastrow
b = Application.WorksheetFunction.VLookup(soneriWs.Range("I" & x).Value, datarange, 2, False)
Idx = InStr(b, "-")
PreTxt = Left(b, Idx)
CntTxt = Mid(b, Idx + 1)
If Dct.Exists(b) Then
Cnt = Dct(b) + 1
Else
Cnt = Val(CntTxt)
End If
Dct(b) = Cnt
'If x > 2 Then
c = PreTxt & Format(Cnt, "0000")
' Use this instead, if you want to preserve the number of characters
'c = PreTxt & Format(Cnt, String(Len(CntTxt), "0"))
soneriWs.Range("D" & x).Value = c
'End If
Next x
End Sub
If you are new to VBA I recommend that you learn how to use the Scripting.Dictionary.
Your loop is only made for a single match of the Asset class.
There are a few problems here, but the if x > 2 approach would really only work if there was only one counter. Then we could substitute + 1 with something like + x - 2 (since we start at 3 for this part of the code).
But what you need is a counter that resets each time there is a new Asset class.
n = 1
For x = 2 To sonerilastrow
b = Application.WorksheetFunction.VLookup( _
soneriWs.Range("I" & x).Value, datarange, 2, False)
soneriWs.Range("D" & x).Value = b
If x > 2 Then
If Not Left(b, 7) = Left(soneriWs.Range("D" & x -1).Value, 7) then
n = 1
else
c = Left(b, 7) & Format(Val(Right(b, 4)) + n, "-0000")
soneriWs.Range("D" & x).Value = c
n = n + 1
End if
End If
Next x
Another way of writing it would be
Dim soneriWs As Worksheet, mappingWs As Worksheet
Dim sonerilastrow As Long, mappinglastrow As Long, i As Long
Dim datarange As Range, assetrange As Range, b As Range
Dim entry As Variant
Set soneriWs = ThisWorkbook.Worksheets("Soneri")
Set mappingWs = ThisWorkbook.Worksheets("Mapping")
sonerilastrow = soneriWs.Range("I" & soneriWs.Rows.Count).End(xlUp).Row
mappinglastrow = mappingWs.Range("A" & mappingWs.Rows.Count).End(xlUp).Row
Set datarange = mappingWs.Range("A2:B" & mappinglastrow)
Set assetrange = soneriWs.Range("I2:I" & sonerilastrow)
i = 0
For Each entry In assetrange
Set b = entry.Offset(, -5)
b = Application.WorksheetFunction.VLookup(entry, datarange, 2, False)
If entry = entry.Offset(-1) Then
i = i + 1
b = Left(b, Len(b) - 1) & (Right(b, 1) + i)
Else
i = 0
End If
Next entry
But it's using much the same approach.
These however expect the data to be sorted on the "I" column, since the counter will reset if there is another asset in between.
If you want it to work even when not sorted, you could use something like countIf, like so: (Replacing the loop)
Set assetrange = soneriWs.Range("I2:I" & sonerilastrow)
assetrange.Offset(, -5).Clear
For Each entry In assetrange
Set b = entry.Offset(, -5)
b = Application.WorksheetFunction.VLookup(entry, datarange, 2, False)
i = Application.WorksheetFunction.CountIf(assetrange.Offset(, -5), Left(b, 5) & "*")
b = Left(b, Len(b) - 1) & (Right(b, 1) + i - 1)
Next entry
i have some label data to print in columns and rows format based on the user defined input Value. their are 3 main inputs based conditions:
1) No of starting label to skip 2) No of label per Row 3) No of Rows Per page
I have one data sheet which has data in column A and No of copies to be printed in column B. i am attaching examples images with different input and output in page i expect to be printed. Also giving link to code which could be relevant for my purpose.
Data Sheet
Print Sheet
My codes are limited to 3 columns with unlimited rows and without skip
Here Can you tweak these codes for Userform : Make it small and efficient are codes for dynamic userfrom textbox creation given by #Brian M Stafford but not sure how to implement for this purpose
Public Sub GenerateLabels()
Dim CopyRowValue As String
Dim SecondDataCol, ThirdDataCol, FirstDataCol As Long
Dim SecondDataRow, ThirdDataRow, FirstDataRow As Long
Set shdata = ThisWorkbook.Sheets("Database")
Set shgenerate = ThisWorkbook.Sheets("LabelGenerate")
Set shDesignFormat = ThisWorkbook.Sheets("LabelDesignFormatBeforePrint")
FirstDataCol = shgenerate.Cells(1, shgenerate.Columns.Count).End(xlToLeft).Column
SecondDataCol = shgenerate.Cells(1, shgenerate.Columns.Count).End(xlToLeft).Column
ThirdDataCol = shgenerate.Cells(1, shgenerate.Columns.Count).End(xlToLeft).Column
FirstDataRow = shgenerate.Cells(shgenerate.Rows.Count, "A").End(xlUp).Row
SecondDataRow = shgenerate.Cells(shgenerate.Rows.Count, "C").End(xlUp).Row
ThirdDataRow = shgenerate.Cells(shgenerate.Rows.Count, "E").End(xlUp).Row
'======== Copy From Data Sheet============
Last_Row = Sheets("Database").Range("A" & Rows.Count).End(xlUp).Row
For r = 2 To Last_Row
shdata.Cells(x, "A").Copy
shDesignFormat.Range("B3").Paste 'pasting data to design sheet before print (to format data)
CopyRowValue = Worksheets("Database").Cells(r, "B").value
For r2 = 1 To CopyRowValue
'=====Paste to Generate Sheet ====
'Cells(FirstDataRow + 1, FirstDataCol + 1).Offset(0, 0).Select
If IsEmpty(shgenerate.Cells(FirstDataRow + 0, FirstDataCol + 0).Offset(0, 0).value) = True Then
shDesignFormat.Range("B3").Copy _
Destination:=shgenerate.Cells(FirstDataRow + 0, FirstDataCol + 0).Offset(0, 0)
ElseIf IsEmpty(shgenerate.Cells(SecondDataRow + 0, SecondDataCol + 2).Offset(0, 0).value) = True Then 'offset used to find empty cell if design layout changed
shDesignFormat.Range("B3").Copy _
Destination:=shgenerate.Cells(SecondDataRow + 0, SecondDataCol + 2).Offset(0, 0)
ElseIf IsEmpty(shgenerate.Cells(ThirdDataRow + 0, ThirdDataCol + 4).Offset(0, 0).value) = True Then
shDesignFormat.Range("B3").Copy _
Destination:=shgenerate.Cells(ThirdDataRow + 0, ThirdDataCol + 4).Offset(0, 0)
SecondDataRow = SecondDataRow + 2
ThirdDataRow = ThirdDataRow + 2
FirstDataRow = FirstDataRow + 2
End If
Next r2
Next r
Application.CutCopyMode = False
End Sub
Looking at your code, my first thought was it could be simplified. Once I did this, I began modifying to add needed requirements. The main task was keeping track of the current location. The code ended up like this:
Option Explicit
Public Sub GenerateLabels(ByVal LabelsToSkip As Integer, ByVal LabelsPerRow As Integer, ByVal RowsPerPage As Integer)
Dim shdata As Worksheet
Dim shgenerate As Worksheet
Dim shDesignFormat As Worksheet
Dim curRow As Long
Dim curCol As Long
Dim RowsPerPageCount As Long
Dim r As Long
Dim r2 As Long
Set shdata = ThisWorkbook.Sheets("Database")
Set shgenerate = ThisWorkbook.Sheets("LabelGenerate")
Set shDesignFormat = ThisWorkbook.Sheets("LabelDesignFormatBeforePrint")
shgenerate.UsedRange.ClearContents
curRow = 1
curCol = 1
RowsPerPageCount = 1
For r = 2 To shdata.Range("A" & Rows.Count).End(xlUp).Row
'======== Copy From Data Sheet============
shdata.Cells(r, "A").Copy
shDesignFormat.Range("B3").PasteSpecial 'pasting data to design sheet before print (to format data)
For r2 = 1 To shdata.Cells(r, "B").Value + LabelsToSkip
'=====Paste to Generate Sheet ====
If curCol > LabelsPerRow * 2 Then '* 2 for double spacing
curCol = 1
If RowsPerPage > 0 And (RowsPerPageCount + 1) Mod (RowsPerPage + 1) = 0 Then
curRow = curRow + 10 'new page
RowsPerPageCount = 1
Else
curRow = curRow + 2
RowsPerPageCount = RowsPerPageCount + 1
End If
End If
If r2 > LabelsToSkip Then
LabelsToSkip = 0
shDesignFormat.Range("B3").Copy Destination:=shgenerate.Cells(curRow, curCol)
End If
curCol = curCol + 2
Next r2
Next r
Application.CutCopyMode = False
End Sub
I recommend using Option Explicit and declaring all variables that you need.
I have a macro (Courtesy of another questions i posted on here) which works perfectly. It searched through data and rearranged it to my needs. It also only outputted information that matched a criteria given (E.g. A cell equals the specified string).
However, now i have added a list box in where the user can select multiple criteria. But i am not sure how i can use VBA to search through the data and only output the data which matches ANY of the list box selections. As shown in the image, if the user selects CONACC and CONPEND, the code should search through the data and then output the values where the cell equals either CONACC or CONPEND.
Any ideas?
Userform Screenshot
'type to manage data we use from each row
Type dataRow
notif As Variant
variable As Variant
sht As Variant
zone As Variant
End Type
Sub DoPivot()
Const SEP As String = "<>"
Dim rngData As Range, data, r As Long
Dim colDict As Object, rowDict As Object, comboDict As Object
Dim rd As dataRow, rngOutput As Range, col As Long, rw As Long, k
Dim k2, arr, dictCounts As Object
Dim wsOut As Worksheet, num As Long
Dim DataWS, OutputtedWS As Worksheet
Dim WS As Worksheet
Dim DataWb, OutputtedWb As Workbook
Dim DataFileName, DataSheetName, DataSheetFilter As String
Set colDict = CreateObject("scripting.dictionary")
Set rowDict = CreateObject("scripting.dictionary")
Set comboDict = CreateObject("scripting.dictionary")
Set dictCounts = CreateObject("scripting.dictionary")
DataFileName = DataFilter.FileLocationTextbox.Value
DataSheetName = DataFilter.SheetNameTextBox.Value
Set OutputtedWb = ThisWorkbook
Set DataWb = Workbooks.Open(DataFileName)
Set DataWS = DataWb.Sheets(DataSheetName)
Set OutputtedWS = Sheets.Add(After:=Sheets(Sheets.Count))
Dim DataWsLastCol As Long, DataWsLastColLet As String
Dim DataWsLastRow As Long
DataWsLastCol = DataWS.Cells(1, DataWS.Columns.Count).End(xlToLeft).Column
DataWsLastColLet = Split(Cells(1, DataWsLastCol).Address, "$")(1)
DataWsLastRow = DataWS.Range("A:" & DataWsLastColLet).SpecialCells(xlCellTypeLastCell).Row
data = DataWS.Range("A2:" & DataWsLastColLet & DataWsLastRow).Value 'source data
Set rngOutput = OutputtedWS.Range("A1") 'top-left cell for output
Set wsOut = rngOutput.Parent
rngOutput.Resize(5000, 5000).ClearContents
rngOutput.Resize(1, 6).Value = Array("Sheet", "Zone", "Feature Code", "Feature Description", "-TEN OGV KH73126 tolerance", "-TEN OGV KH73126 tolerance")
OutputtedWS.Cells(2, 5) = "Nominal"
OutputtedWS.Cells(2, 6) = "Tolerance"
Set notif = DataWS.Rows("1:1").Find(What:="Notification", lookat:=xlWhole)
Set variable = DataWS.Rows("1:1").Find(What:="Extent Var.", lookat:=xlWhole)
Set sht = DataWS.Rows("1:1").Find(What:="Sheet", lookat:=xlWhole)
Set zone = DataWS.Rows("1:1").Find(What:="Zone", lookat:=xlWhole)
Set CodeGroup = DataWS.Rows("1:1").Find(What:="Code group", lookat:=xlWhole)
notifcol = notif.Column
variablecol = variable.Column
shtcol = sht.Column
zonecol = zone.Column
CodeGroupCol = CodeGroup.Column
col = rngOutput.Column + 6 'start for notification# headers
rw = rngOutput.Row + 2
'first pass - assess data variables
For r = 1 To UBound(data, 1)
If data(r, CodeGroupCol) = [[[[[[THIS IS WHERE THE SELECTION WOULD GO]]]]]] Then
rd = rowData(data, r, notifcol, variablecol, shtcol, zonecol)
k = Join(Array(rd.sht, rd.zone, rd.notif), SEP) 'tracking how many unique combinations of these
comboDict(k) = comboDict(k) + 1 'increment count
'manage column header positions for unique notification numbers
If Not colDict.exists(rd.notif) Then
colDict.Add rd.notif, col 'store the column
rngOutput.EntireRow.Cells(1, col).Value = rd.notif 'add the header
col = col + 1
End If
End If
Next r
'figure out # of rows for each sheet-Zone pair
For Each k In comboDict.keys
arr = Split(k, SEP)
k2 = Join(Array(arr(0), arr(1)), SEP) 'sheet<>zone
'is this more rows than any previous same k2 value?
dictCounts(k2) = Application.Max(dictCounts(k2), comboDict(k))
Next k
'create the row headers
For Each k In dictCounts.keys
num = dictCounts(k)
rowDict(k) = rw 'record start row for each sheet<>zone combo
wsOut.Cells(rw, rngOutput.Column).Resize(num, 2).Value = Split(k, SEP)
dictCounts(k) = 0 'reset so we can track while adding data
rowDict(k) = rw
rw = rw + num
Next k
'last pass - populate the data based on the dictionaries
For r = 1 To UBound(data, 1)
If data(r, CodeGroupCol) = [[[[[[THIS IS WHERE THE SELECTION WOULD GO]]]]]] Then
rd = rowData(data, r, notifcol, variablecol, shtcol, zonecol)
k = Join(Array(rd.sht, rd.zone, rd.notif), SEP) '3-field combo
k2 = Join(Array(rd.sht, rd.zone), SEP) 'row key
wsOut.Cells(rowDict(k2) + (dictCounts(k)), _
colDict(rd.notif)).Value = rd.variable
dictCounts(k) = dictCounts(k) + 1 'increment this unique combo
End If
Next r
End Sub
'populate a Type instance for a given row
Function rowData(data, r As Long, notficationcol, variablecol, sheetcol, zonecol) As dataRow
Dim rv As dataRow
rv.notif = IfEmpty(data(r, notficationcol))
rv.variable = IfEmpty(data(r, variablecol))
rv.sht = IfEmpty(data(r, sheetcol))
rv.zone = IfEmpty(data(r, zonecol))
rowData = rv
End Function
'substitute EMPTY for zero-length value
Function IfEmpty(v)
IfEmpty = IIf(Len(v) = 0, "EMPTY", v)
End Function
Add another dictionary
Dim i As Integer, dictFilter As Object
Set dictFilter = CreateObject("scripting.dictionary")
With DataFilter.ListBox1
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
dictFilter.Add .List(i), 1
End If
Next
End With
If dictFilter.exists(data(r, CodeGroupCol)) Then
'
'
End If
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
I'm currently working on a project which needs to build graph regarding to a table of analyses to check if the products work with time.
The user starts to choose which products he want to check and the code create a table regarding that.
The two main values are the date and the result which need to be on the graph and the third one is the batch number which needs to be the name of each chart series.
After that the code creates a 2D array with the table.
For Each elementReo In Range("tabReorganize[Date]")
ReDim Preserve tabReo(2, r)
tabReo(0, r) = elementReo
tabReo(1, r) = 0 & elementReo.Offset(0, 1)
tabReo(2, r) = elementReo.Offset(0, 2)
r = r + 1
Next elementReo
And after that I want to create the graph regarding to the number of different batch number that I have.
'This part create the Chart and set the title
Set ChartObj = ActiveSheet.ChartObjects.Add(Left:=2979.75, Width:=550, Top:=358.5, Height:=325)
ChartObj.Chart.ChartType = xlLine
ChartObj.Chart.SetElement (msoElementChartTitleAboveChart)
ChartObj.Chart.ChartTitle.Text = "Humidite"
Dim tabNBN() As String
Dim NBN As Integer
Dim checkNBN As Boolean
ReDim tabNBN(NBN)
Dim SeriesI As Integer
NBN = 0
SeriesI = 0
'Add value in tabNBN regarding to the number of different batch number
For r2 = 0 To r - 1 Step 1
checkNBN = False
For Each elementNBN In tabNBN
If elementNBN = tabReo(1, r2) Then
checkNBN = True
End If
Next elementNBN
If checkNBN = False Then
ReDim Preserve tabNBN(NBN)
tabNBN(NBN) = tabReo(1, r2)
NBN = NBN + 1
End If
Next r2
So I need something to add the series regarding of the number of different batch number and insert the value and the date there.
I'm a beginner with charts in VBA.
if my understanding of the objective is correct then congratulation for a good & challenging question. Assuming the objective is to create a single chart with multiple series representing each batch listed in the range. If assumed result is like the following
then may try the test code (obviously after modifying the range, sheet etc to requirement). The code used Dictionary object, so please add Tools-> Reference to "Microsoft Scripting Runtime". Though I am not fully satisfied with the code regarding some multiple looping etc (degrading the performance) but would work OK with normal data assuming 100/200 rows. I invite experts response for more efficient code in this regard
Option Explicit
Sub test3()
Dim Cht As Chart, ChartObj As ChartObject
Set ChartObj = ActiveSheet.ChartObjects.Add(Left:=10, Width:=550, Top:=10, Height:=325)
'Set ChartObj = ActiveSheet.ChartObjects("Chart 4")
Set Cht = ChartObj.Chart
Cht.ChartType = xlLine
Cht.HasTitle = True
Cht.ChartTitle.Text = "Humidite"
Dim Rw As Long, Dic As Dictionary, DataArr As Variant, OutArr() As Variant, BatchArr() As Variant, DateArr As Variant
Dim Rng As Range, SeriesNo As Long, Dmax As Date, Dmin As Date, dt As Date
Dim X As Long, i As Long, Xbatch As Variant, Batch As Variant
Dim Cnt As Long, Xval As Variant, PrvDt As Date, C As Range, DayCnt As Long
Dim firstAddress As String
Set Dic = CreateObject("Scripting.dictionary")
Set Rng = ThisWorkbook.ActiveSheet.Range("A2:A100") 'Modify to requireMent
DataArr = ThisWorkbook.ActiveSheet.Range("A2:C100") 'Modify to requireMent
SeriesNo = 0
'Create dictionary reference to unique Batch name from the list
For Rw = 1 To UBound(DataArr, 1)
Batch = DataArr(Rw, 2)
If Dic.Exists(Batch) = False Then
SeriesNo = SeriesNo + 1
Dic.Add Batch, SeriesNo
End If
Next
Dmax = Application.WorksheetFunction.Max(Range(Rng(1, 1), Rng(Rng.Rows.Count, 1)))
Dmin = Application.WorksheetFunction.Min(Range(Rng(1, 1), Rng(Rng.Rows.Count, 1)))
DayCnt = Dmax - Dmin + 1
ReDim BatchArr(1 To DayCnt)
ReDim DateArr(1 To DayCnt)
ReDim OutArr(1 To SeriesNo, 1 To DayCnt)
'Populate DateArr for dates
For X = 1 To DayCnt
DateArr(X) = Dmin + X - 1
Next
'Populate OutArr(Series,DayCnt) with existing Values, Non existing values are kept empty
For X = 1 To DayCnt
dt = DateArr(X)
With Rng
Set C = .Find(dt)
If Not C Is Nothing Then
firstAddress = C.Address
Do
OutArr(Dic(C.Offset(0, 1).Value), X) = C.Offset(0, 2).Value
'Debug.Print C.Value, C.Offset(0, 1).Value, C.Offset(0, 2).Value
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
End If
End With
Next
With Cht
'delete If any automatically added series
For i = Cht.SeriesCollection.Count To 1 Step -1
.SeriesCollection(i).Delete
Next
'Create Series and Set Values & Xvalues from OutArr
Dim Srs As Series
For X = 1 To SeriesNo
Batch = Dic.Keys(X - 1)
For Cnt = 1 To DayCnt
BatchArr(Cnt) = OutArr(Dic(Batch), Cnt)
'If IsEmpty(BatchArr(Cnt)) = False Then Debug.Print X, Cnt, BatchArr(Cnt), DateArr(Cnt)
Next
Cht.SeriesCollection.NewSeries
Set Srs = Cht.SeriesCollection(X)
With Srs
.Values = BatchArr
.XValues = DateArr
.Name = Dic.Keys(X - 1)
End With
Next
Dim Cat As Axis
Set Cat = Cht.Axes(xlCategory)
Cat.TickLabels.NumberFormat = "dd/mm/yy"
End With
End Sub
Please comment if it suits your need
This code should create a table regarding to another table (the one with all different batch numbers and values) and the user selection and after build the chart with it.
I can send you the full file by mail if needed.
Thanks in advance.
Best regards
colin
Private Sub BtnGraph2_Click()
Dim tabBNumber() As String
Dim tabHumidite() As Double
Dim tabDate() As String
Dim tabReo() As String
Dim y As Integer
Dim h As Integer
Dim d As Integer
Dim a As Integer
Dim w As Integer
Dim w2 As Integer
Dim r As Integer
h = 0
y = 0
d = 0
w = 1
w2 = 1
r = 0
ReDim tabHumidite(h)
ReDim tabBNumber(y)
ReDim tabDate(d)
Range("tabReorganize[#data]") = ""
ListObjects("tabReorganize").Resize Range(Range("tabReorganize[#headers]").Address, Range("tabReorganize[#headers]").Offset(1).Address)
For i6 = ListBox1.ListCount - 1 To 0 Step -1
If ListBox1.Selected(i6) = True Then
ReDim Preserve tabBNumber(y)
tabBNumber(y) = ListBox1.List(i6)
y = y + 1
End If
Next i6
For Each delement In tabBNumber
For Each delement2 In Range("tabGraph[Date]")
If "0" & delement2.Offset(0, 2) = delement Or delement2.Offset(0, 2) = delement Then
ReDim Preserve tabDate(d)
tabDate(d) = delement2
d = d + 1
End If
Next delement2
Next delement
For Each Oelement In tabDate
Range("tabReorganize[Date]").Cells(w) = Format(Oelement, "mm/dd/yyyy")
w = w + 1
Next Oelement
If BtnHumidite = True Then
For Each element In tabBNumber
h = 0
a = 0
ReDim tabHumidite(h)
For Each Gelement In Range("tabGraph[Humidite]")
If "0" & Gelement.Offset(0, -1) = element Or Gelement.Offset(0, -1) = element Then
ReDim Preserve tabHumidite(h)
tabHumidite(h) = Gelement
h = h + 1
End If
Next Gelement
For Each O2element In tabHumidite
Range("tabReorganize[Humidite]").Cells(w2) = Format(O2element, "###0.00")
Range("tabReorganize[Batch Number]").Cells(w2) = Format(element, "00000000")
w2 = w2 + 1
Next O2element
Next element
End If
Range("tabReorganize").Sort Key1:=Range("tabReorganize[[#All],[Date]]"), Order1:=xlAscending, Header:=xlYes
For Each elementReo In Range("tabReorganize[Date]")
ReDim Preserve tabReo(2, r)
tabReo(0, r) = elementReo
tabReo(1, r) = 0 & elementReo.Offset(0, 1)
tabReo(2, r) = elementReo.Offset(0, 2)
r = r + 1
Next elementReo
'''' Chart part
Dim Cht As Chart, ChartObj As ChartObject
Set ChartObj = ActiveSheet.ChartObjects.Add(Left:=2979.75, Width:=550, Top:=358.5, Height:=325)
Set Cht = ChartObj.Chart
Cht.ChartType = xlLine
Cht.HasTitle = True
Cht.ChartTitle.Text = "Humidite"
Dim Rw As Long, Dic As Dictionary, DataArr As Variant, OutArr() As Variant, BatchArr() As Variant, DateArr As Variant
Dim Rng As Range, SeriesNo As Long, Dmax As Date, Dmin As Date, dt As Date
Dim X As Long, i As Long, Xbatch As Variant, Batch As Variant
Dim Cnt As Long, Xval As Variant, PrvDt As Date, C As Range, DayCnt As Long
Dim firstAddress As String
Set Dic = CreateObject("Scripting.dictionary")
Set Rng = ThisWorkbook.ActiveSheet.Range("AP13:AP42") 'Modify to requireMent
'Set Rng = ThisWorkbook.ActiveSheet.Range("tabReorganize[Date]")
DataArr = ThisWorkbook.ActiveSheet.Range("AP13:AR42") 'Modify to requireMent
'DataArr = ThisWorkbook.ActiveSheet.Range("tabReorganize[#data]")
SeriesNo = 0
'Create dictionary reference to unique Batch name from the list
For Rw = 1 To UBound(DataArr, 1)
Batch = DataArr(Rw, 2)
If Dic.Exists(Batch) = False Then
SeriesNo = SeriesNo + 1
Dic.Add Batch, SeriesNo
End If
Next
Dmax = Application.WorksheetFunction.max(Range(Rng(1, 1), Rng(Rng.Rows.Count, 1)))
Dmin = Application.WorksheetFunction.Min(Range(Rng(1, 1), Rng(Rng.Rows.Count, 1)))
DayCnt = Dmax - Dmin + 1
ReDim BatchArr(1 To DayCnt)
ReDim DateArr(1 To DayCnt)
ReDim OutArr(1 To SeriesNo, 1 To DayCnt)
'Populate DateArr for dates
For X = 1 To DayCnt
DateArr(X) = Dmin + X - 1
Next
'Populate OutArr(Series,DayCnt) with existing Values, Non existing values are kept empty
For X = 1 To DayCnt
dt = DateArr(X)
With Rng
Set C = .Find(dt)
If Not C Is Nothing Then
firstAddress = C.Address
Do
OutArr(Dic(C.Offset(0, 1).Value), X) = C.Offset(0, 2).Value
'Debug.Print C.Value, C.Offset(0, 1).Value, C.Offset(0, 2).Value
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
End If
End With
Next
With Cht
'delete If any automatically added series
For i = Cht.SeriesCollection.Count To 1 Step -1
.SeriesCollection(i).Delete
Next
'Create Series and Set Values & Xvalues from OutArr
Dim Srs As Series
For X = 1 To SeriesNo
Batch = Dic.Keys(X - 1)
For Cnt = 1 To DayCnt
BatchArr(Cnt) = OutArr(Dic(Batch), Cnt)
'If IsEmpty(BatchArr(Cnt)) = False Then Debug.Print X, Cnt, BatchArr(Cnt), DateArr(Cnt)
Next
Cht.SeriesCollection.NewSeries
Set Srs = Cht.SeriesCollection(X)
With Srs
.Values = BatchArr
.XValues = DateArr
.Name = Dic.Keys(X - 1)
End With
Next
Dim Cat As Axis
Set Cat = Cht.Axes(xlCategory)
Cat.TickLabels.NumberFormat = "mm/dd/yy"
End With