I’ve reviewed 10s of reported problems with similar error code but none match my scenario..
I have a ListBox that I populate using the .List property... The ListBox behaves as expected except when (in sequence):
1. I filter out non-selected items and reset the .List property with the filtered items (no issues there)
2. I attempt to “mark” all items as selected (I get the error as soon as I set the .Selected property for the first item).
Here is the code (I’ve tried many different variations, but this is the “cleanest”):
Set rngTarget = rngTarget.Range(rngTarget.Cells(2, 1), rngTarget.Cells(rngTarget.Rows.Count, lbSelection.ColumnCount))
lbSelection.Clear
lbSelection.List = rngTarget.Cells.Value
lItemCnt = lbSelection.ListCount - 1
For lItemNdx = 0 To lItemCnt
lbSelection.Selected(lItemNdx) = True
Next lItemNdx
The error occurred on the first encounter of lbSelection.Selected(lItemNdx) = True. All the indices are valid, the dataset/range is valid with all rows/columns having valid data, and there are only 5 columns in the list (i.e., less than the max of 10). I’ve also tried to first assign the dataset (range) to a variant and then the variant to the .List property, but that didn’t make a difference. I’ve also tried “unmarking” all items before clearing the list.. What is interesting is that, in the debugger when the error is encountered, the .ListCount property shows the correct number of rows. HOWEVER, the GUI shows a blank list.
Any help would be greatly appreciated.
P.S. Populating the ListBox “manually” using .AddItem method is not a practical option for my purposes (nor using .RowSource property).
Environment: Excel 2010, standard. Windows 7 Pro.
Enclosing fuller code for review (data not enclosed but consists of 457 rows [first row is header and not part of the listbox] and 5 columns --all text). To replicate the issues, simply deselect the first item in the list.
Button to call userform:
`Sub LoadSampleForm()
frmTestLB.InitControls
End Sub`
Userform code:
` Option Explicit
Private bIgnorEvents As Boolean
Public Sub InitControls()
Dim lItemNdx As Long
Dim lItemCnt As Long
bIgnorEvents = True
lbSelection.Clear
lbSelection.ColumnCount = 5
lbSelection.ColumnWidths = "45 pt;155 pt;70 pt;70 pt;70 pt"
lbSelection.List = Worksheets("Sample").Range(Worksheets("Sample").Cells(2, 1), Worksheets("Sample").Cells(457, 5)).Value
lItemCnt = lbSelection.ListCount - 1
For lItemNdx = 0 To lItemCnt
lbSelection.Selected(lItemNdx) = True
Next lItemNdx
bIgnorEvents = False
Me.Show
End Sub
Private Sub lbSelection_Change()
Dim bAppAlert As Boolean
Dim lItemCnt As Long
Dim lItemNdx As Long
Dim lKeyColNdx As Long
Dim rngTarget As Range 'Temporary range for items to be searched
Dim wsTemp As Worksheet 'Temporary worksheet used for target range and applying Lookup function
If (Not bIgnorEvents) Then
bIgnorEvents = True
Set wsTemp = ThisWorkbook.Worksheets.Add
lKeyColNdx = 1
lItemCnt = lbSelection.ListCount + 1
wsTemp.Range(Cells(2, 1), Cells(lItemCnt, lbSelection.ColumnCount)).Value = lbSelection.List
Set rngTarget = wsTemp.Range(Cells(1, 1), Cells(lItemCnt, lbSelection.ColumnCount + 1))
rngTarget.Cells(1, lbSelection.ColumnCount + 1).Value = "Selected"
For lItemNdx = 2 To lItemCnt
If (lbSelection.Selected(lItemNdx - 2)) Then
rngTarget.Cells(lItemNdx, lbSelection.ColumnCount + 1).Value = 1
Else
rngTarget.Cells(lItemNdx, lbSelection.ColumnCount + 1).Value = 0
End If
Next lItemNdx
rngTarget.AutoFilter Field:=lbSelection.ColumnCount + 1, Criteria1:="=0"
rngTarget.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
wsTemp.AutoFilterMode = False
Set rngTarget = rngTarget.Range(rngTarget.Cells(2, 1), rngTarget.Cells(rngTarget.Rows.Count, lbSelection.ColumnCount))
lbSelection.Clear
lbSelection.List = rngTarget.Cells.Value
lItemCnt = lbSelection.ListCount - 1
For lItemNdx = 0 To lItemCnt
lbSelection.Selected(lItemNdx) = True
Next lItemNdx
'Clean-up: Remove temp sheet without prompts
bAppAlert = Application.DisplayAlerts 'Current setting
Application.DisplayAlerts = False 'Supress DisplayAlerts
wsTemp.Delete 'Delete temp sheet
Application.DisplayAlerts = bAppAlert 'Restore original DisplayAlerts setting
Set rngTarget = Nothing
Set wsTemp = Nothing
bIgnorEvents = False
End If
End Sub`
Try changing the line:
lbSelection.List = rngTarget.Cells.Value
To:
lbSelection.List = rngTarget
Related
I have a call procedure to clear contents of tables across multiple worksheets.
This procedure is invoked only from the 2nd sheet of the workbook. When I invoke this, I am getting Error 1004 "Application-defined or Object-defined error".
Below is the parent code base invoking the sub procedure:
Sub ValidateData_BDV1()
On Error Resume Next
Err.Clear
'''''Define Variables'''''''''
Dim mySheet As Worksheet
Dim mySheetName As String
Dim bdvName As Variant
Dim sqlQuery As String
Dim connectStr As String
Dim wsMatch As Worksheet
Dim myWorkbook As Workbook: Set myWorkbook = ThisWorkbook
'''''''''Set Variables''''''''
cancelEvent = False
Set mySheet = ActiveSheet 'Sets mySheet variable as current active sheet
mySheetName = mySheet.Name
driverName = mySheet.Range("B1").Value2 'Get the value of the TDV driver
' MsgBox driver
dataSourceName = mySheet.Range("B3").Value2 'Get the data source name for the published TDV database
' MsgBox dataSourceName
schemaName = mySheet.Range("B5").Value2 'Get the schema name of the published tdv view
bdvName = mySheet.Range("B6").Value2 'Get the name of the published BDV
''''''''''Refresh data across sheets'''''''''''''
Application.ScreenUpdating = False 'Prevent screen flickering while doing the refresh
'''''''''''''''''''''''''''''''''''''''
''''''''''''Call sub procedure'''''''''
Call ClearTableContents
''''''''''''''''''''''''''''''''''''
mySheet.Activate
Application.ScreenUpdating = True 'Prevent screen flickering while doing the refresh
''''''''Show User id and Password box'''''''''
If Len(Uid) < 1 Or Len(Password) < 1 Then
UserForm1.Show
End If
If (cancelEvent = True) Then
Exit Sub
End If
............
............perform some task with error handling
Below is the code base of the called Sub
Sub ClearTableContents()
Dim wrksht As Worksheet
Dim objListObj As ListObjects
Dim tableName As String
Dim ActiveTable As ListObject
Dim rowCount As Integer
Dim colCount As Integer
Dim i As Integer
Dim j As Integer
'''''Iterate through the Bdv1, bdv2 and Match sheets. Set default table sizes for each
sheet'''''''''
For j = 2 To 4
If (j = 2) Or (j = 3) Then
rowCount = 5
colCount = 6
ElseIf (j = 4) Then
rowCount = 5
colCount = 9
End If
Application.ScreenUpdating = False 'Prevent screen flickering while doing the refresh
Set wrksht = ActiveWorkbook.Worksheets(j)
Set objListObj = wrksht.ListObjects 'Get list of tables objects from the current sheet
'''''''Iterate through the tables in the active worksheet''''''''''''''
For i = 1 To objListObj.Count
tableName = objListObj(i).Name
Set ActiveTable = wrksht.ListObjects(tableName)
On Error Resume Next
''''''For each table clear the contents and resize the table to default settings''''''''''''
With wrksht.ListObjects(i)
.DataBodyRange.Rows.Clear
.Range.Rows(rowCount & ":" & .Range.Rows.Count).Delete
.HeaderRowRange.Rows.ClearContents
.HeaderRowRange.Rows.Clear
.Range.Columns(colCount & ":" & .Range.Columns.Count).Delete
.Resize .Range.Resize(rowCount, colCount)
End With
wrksht.Columns("A:Z").AutoFit
Next i
Next j
ThisWorkbook.Worksheets(2).Activate '''set the active sheet to the sheet number 2
Application.ScreenUpdating = True 'Prevent screen flickering while doing the refresh
Exit Sub
'Error Handling
NoTableSelected:
MsgBox "There is no Table currently selected!", vbCritical
End Sub
Please help in resolving the issue.
If I execute as independent macro on click of the button, it works perfectly well.
I am going to post this as an "answer", since I think it may at least help, if not solve, your issue.
Clearing tables (list objects) via VBA code can be a little tricky, and I learned this hard way. I developed and have been using the below function for quite some time and it works like a charm. There are comments to explain the code in the function.
Sub clearTable(whichTable As ListObject)
With whichTable.DataBodyRange
'to trap for the bug where using 'xlCellTypeConstants' against a table with only 1 row and column will select all constants on the worksheet - can't explain more than that its a bug i noticed and so did others online
If .rows.count = 1 And .columns.count = 1 Then
If Not .Cells(1, 1).HasFormula Then .Cells(1, 1).ClearContents
Else
'my tables often have formulas that i don't want erased, but you can remove if needed
On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End If
'remove extra rows so table starts clean
Dim rowCount As Long
rowCount = .rows.count
If rowCount > 1 Then .rows("2:" & rowCount).Delete 'because you can't delete the first row of the table. it will always have 1 row
End With
End Sub
Call the procedure like this:
Dim lo as ListObject
For each lo in Worksheets(1).ListObjects
clearTable lo
next
Commented line to make my code work
.Range.Columns(colCount & ":" &
.Range.Columns.Count).Delete
I have a Word file with approximately 10 pages and 20 tables. Some of these tables have checkboxes. I want to copy these tables into an Excel file.
The following code copies all tables from my Word file into my Excel file:
Sub Import()
Option Explicit
Dim wb As Workbook
Dim sh As Worksheet
Dim sheet As Worksheet
Dim lzeile As Integer
Set wb = ActiveWorkbook
Set sh = wb.ActiveSheet
Set sheet = wb.Worksheets("Tabelle1")
Dim Btxt As Object
Set Btxt = CreateObject("Word.Application")
Btxt.Visible = True
Btxt.documents.Open "C:\Users\*.doc" '*=path
lzeile = 0
For i = 1 To 20
Btxt.ActiveDocument.Tables(i).Range.Copy
Application.Goto sheet.Cells(1 + lzeile, 1)
sheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
lzeile = sheet.Cells(Rows.Count, 1).End(xlUp).Row
lzeile = lzeile + 1
sheet.Cells(lzeile, 1) = "Tabelle" & i
Next i
Btxt.Quit
Set Btxt = Nothing
Set wb = Nothing
Set sh = Nothing
End Sub
It does not copy checkboxes or the value (0 = not checked / 1 = checked) of the checkbox.
I can write the value of a checkbox into a cell in my excel sheet with this line:
sheet.Cells(j, 10) = Btxt.ActiveDocument.Tables(i).FormFields.Item("Kontrollkästchen" & j).Result
With a loop j over all "Kontrollkästchen" (german translation of contentcontrol or formfield item) so basically the name of all formfield items in this Word file.
How can I get the position of these formfield items or identify which formfield item / ContentControl is in which table?
I tried to go through all rows and columns in each table because none of them are larger than 10x10. But I can´t find a way to check if a checkbox is maybe in table 3 on column 5 row 5 and then read the name of this checkbox to a safe the value (0 / 1) in the Excel cell on the same position in my copied table.
The solution depends on whether they're formfields or content controls.
Assuming they're formfields:
Sub Demo()
Dim i As Long, j As Long, Rng As Range
With ActiveDocument
For i = .FormFields.Count To 1 Step -1
With .FormFields(i)
If .Type = wdFieldFormCheckBox Then
j = Abs(.CheckBox.Value)
Set Rng = .Range
.Delete
Rng.Text = j
End If
End With
Next
End With
End Sub
Assuming they're content controls:
Sub Demo()
Dim i As Long, j As Long, Rng As Range
With ActiveDocument
For i = .ContentControls.Count To 1 Step -1
With .ContentControls(i)
If .Type = wdContentControlCheckBox Then
j = Abs(.Checked)
Set Rng = .Range
.Delete
Rng.Text = j
End If
End With
Next
End With
End Sub
For the sake of simplicity and clarity, the sample code below leaves out the parts having to do with Excel, as well as creating the instance of the Word Application. It shows only how to access the Word document's checkboxes and convert those to static values.
At the end, also, the document is closed without saving changes, which means forms protection and the checkboxes should be left intact - the macro will not have affected them.
Note: You should have Option Explicit at the top of the code page, not inside a "Sub".
How it works
The document to be processed is opened and at that moment set to an object (doc). Use this instead of ActiveDocument as it will be much clearer and, in case the user would try to do something, won't affect macro execution.
If the document has forms protection, this must be turned off in order to delete the checkboxes and insert static values.
Then all the form fields are looped. If they are checkboxes, the value is determined, the checkbox removed and the value assigned to the range the checkbox occupied.
After this has completed comes the code to transfer data to Excel. Then the document is closed without saving changes.
Sub ConvertCheckBoxesToValues()
Dim ff As Object ' Word.FormField
Dim doc As Object ' Word.Document
Dim cbValue As String
Dim rngFF As Object ' Word.Range
Set doc = Btxt.Documents.Open("C:\Users\*.doc") '*=path
If doc.ProtectionType <> -1 Then 'wdNoProtection
doc.Unprotect
End If
For Each ff In doc.FormFields
If ff.Type = 71 Then 'wdFieldFormCheckBox
If ff.CheckBox.value = True Then
cbValue = "1"
Else
cbValue = "0"
End If
Set rngFF = ff.Range
ff.Delete
rngFF = cbValue
End If
Next
'Transfer the information to Excel, then
doc.Close 0 'wdDoNotSaveChanges
End Sub
i just like to open several source files (all excel) and always copy the complete data rom sheet 1 into my target-sheet. First part works well.
The unusual thing is that i want the tables to be merged from the left to right (horizontical), not from top down.
Of course the range needs to adjust dynamically. The allocation part is also working. Whats not working is to copy it over my target sheet and always add from left to right.
Means
Worksheet 1 hast data from A1:C10
Worksheet 2 has data from A1:B20
should be merged like
Worksheet 1 hast data from A1:C10 -> A1:C10
Worksheet 2 has data from A1:B20 -> D1:E20
etc. I cannot do this. It either gives me a 1004, or says that the object doesnt support the method.
Here's the code:
Application.ScreenUpdating = False 'Das "Flackern" ausstellen
Set oTargetSheet = ActiveWorkbook.Sheets.Add
lErgebnisSpalte = 1
sPfad = "C:\Users\TEST\"
sDatei = Dir(CStr(sPfad & "*.xl*"))
Do While sDatei <> ""
Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True)
z1 = oSourceBook.Sheets(1).UsedRange.Rows.Count
s1 = oSourceBook.Sheets(1).UsedRange.Columns.Count
**oSourceBook.Sheets(1).Range(oSourceBook.Cells(1, 1), oSourceBook.Cells(z1, s1)).Copy oTargetSheet.Range(oTargetSheet.Cells(1, lErgebnisSpalte), oTargetSheet.Cells(z1, s1))**
lErgebnisSpalte = lErgebnisSpalte + 1
oSourceBook.Close False 'nicht speichern
'Next File
sDatei = Dir()
Loop
Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
'Variablen aufräumen
Set oTargetSheet = Nothing
Set oSourceBook = Nothing
End Sub
Debug keeps saying:
Object doesnt support the method; and marks this line:
**oSourceBook.Sheets(1).Range(oSourceBook.Cells(1, 1), oSourceBook.Cells(z1, s1)).Copy oTargetSheet.Range(oTargetSheet.Cells(1, lErgebnisSpalte), oTargetSheet.Cells(z1, s1))**
This works for me (in this case I just copy the existing range into the next free column)
Private Sub Worksheet_Activate()
Dim colNr As Integer
For i = 1 To 100
colNr = ThisWorkbook.ActiveSheet.Range("A1").End(xlToRight).Column
colNr = colNr + 1
ThisWorkbook.ActiveSheet.Range("A1:B5").Copy Destination:=ThisWorkbook.ActiveSheet.Cells(1, colNr)
Next i
End Sub
I hope this helped.
I have an Access 2010 application where I run a SQL query and output the results to Excel. I'm using the Excel subtotal command to create subtotals. That works fine, but on the total rows only the text ("XXX Count") is bold and the values are not bold. Our client would like the entire row bold. I've tried a couple ways without success. How do I do the entire row in the subtotals?
So here is what I currently have:
This is correct except I need all of row 5, 8, 16, and 17 bold like this:
Here is my code to create the Excel file from Access (this all works except for the bold issues):
Public Sub ExportToExcel(query)
Dim appXL As Object
Dim wbk As Object
Dim wksNew As Object
Set appXL = CreateObject("Excel.Application")
Set wbk = appXL.Workbooks.Add
Set wksNew = wbk.Worksheets("Sheet1")
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Set appXL = CreateObject("Excel.Application")
appXL.Visible = True
Set wbk = appXL.Workbooks.Add
Set wksNew = wbk.Worksheets(1)
Set cn = CurrentProject.AccessConnection
Set rs = New ADODB.Recordset
With rs
Set .ActiveConnection = cn
.Source = query
.Open
End With
With rs
'Put recordset into new wks
wksNew.Cells(2, 1).CopyFromRecordset rs
'And add headers
Dim i As Long
For i = 0 To .Fields.Count - 1
wksNew.Cells(1, i + 1).Value = .Fields(i).Name
wksNew.Cells(1, i + 1).Font.Bold = True
wksNew.Cells(1, i + 1).HorizontalAlignment = xlCenter
Next i
'Now, while the recordset is available...
'The recordset has .fields.count fields
'Subtotals are wanted from field 7 to the end
If .Fields.Count > 13 Then
ReDim ary(14 To .Fields.Count - 1)
For i = LBound(ary) To UBound(ary)
ary(i) = i
Next i
wksNew.Cells(1, 1).CurrentRegion.SubTotal GroupBy:=1, _
TotalList:=ary, Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End If
.Close
End With
End Sub
I tried this code based on this website:
Dim rCell As Range
wksNew.Columns("A:A").Select
Dim rCell As Range
For Each rCell In Selection
If Right(rCell.Value, 5) = "Count" Then
Rows(rCell.Row).Interior.ColorIndex = 36
End If
Next
but it returned a "Method or data member not found" error on the item rCell.Value.
I also tried it like this:
Dim rCell As Range
wksNew.Columns("A:A").Select
For Each rCell In Selection
If Right(rCell, 5) = "Count" Then
Selection.Font.Bold = True
End If
Next
But I got the error "ActiveX component can't create object" on the For Each line.
How do I bold the entire row for the subtotals?
You're getting an error because Access doesn't know what Selection is unless you tell it that it's connected to your Excel instance.
For Each rCell In Selection
However, don't need to select anything, or check the whole column:
Dim rCell As Range
For Each rCell In wksNew.UsedRange.Columns(1).Cells
If Right(rCell, 5) = "Count" Then
rCell.Font.Bold = True
End If
Next
Have you tried a Pivot Table?? It is easier to manage format or layout and you don't have to change too much your code because you just put your RecordSet in a PivotTableCache like the second example in this.
Rather than looping, I'd suggest collapsing the outline and formatting the visible cells:
with wksNew.Cells(1, 1).CurrentRegion
.Outlinelevel = 2
.specialcells(12).Font.Bold = True
.Outlinelevel = 3
End With
Thanks for all the suggestions. No one posted a solution that worked entirely, so here's what I ended up using:
Dim c As Object
For Each c In wksNew.Range("A1:A500")
If c.Value Like "*Total" Then
c.Offset(0, 13).Font.Bold = True
c.Offset(0, 14).Font.Bold = True
c.Offset(0, 15).Font.Bold = True
End If
Next
The only thing that concerns me is that I'm assuming this only has 500 rows. I couldn't find a way to find the number of rows and have it search only those. If I included the whole column, it took a couple minutes to complete the loop which I didn't think the client would like. Any suggestions on how to find the last row?
I would
Display level 2 of the outline, all the subtotals
Select the whole area
Use GoTo Special to select only visible cells
Apply the formatting
Change the header row formatting if it should be different
Display all the levels again (level 3)
This code demonstrates:
Sub Macro4()
Application.ScreenUpdating = False
ActiveSheet.Outline.ShowLevels RowLevels:=2
Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Font.Bold = True
'change the header row if necessary
Range(Range("A1"), Range("A1").End(xlToRight)).Font.Italic = True
ActiveSheet.Outline.ShowLevels RowLevels:=3
End Sub
I have a 13 row range with the first row a header row and the next 12 rows filled in by a QueryTable. The query will return at most 12 rows, but possibly less. Below this range I have a totals row.
I want to hide any rows that do not have data and I'm using AutoFilter to do this. When I run the code it creates the AutoFilter but doesn't apply the criteria. If I step through the code, it works just fine. Any ideas?
Sub fillTable()
Dim strConn As String
Dim strSQL As String
Dim qt As QueryTable
Sheet15.AutoFilterMode = False
Sheet15.Range("DCRTable").ClearContents
strConn = "ODBC;DSN=MS Access Database;DBQ=<db path>;"
Set qt = Sheet15.QueryTables.Add(strConn, Sheet15.Range("DCRTable"))
qt.CommandText = <sql query>
qt.AdjustColumnWidth = False
qt.EnableRefresh = False
qt.FieldNames = False
qt.Refresh
hideEmpties Sheet15.Range("DCRTable").offset(-1).Resize(13)
End Sub
Sub hideEmpties(rng As Range)
rng.Parent.AutoFilterMode = False
With rng
.AutoFilter
.AutoFilter 1, "<>", , , False
End With
End Sub
First of all, I cannot see how you assigned your sheet to object "Sheet15" - maybe this is part of the problem. If you have a named range, you don't need a Sheet object before that.
Secondly, .Autofilter with no arguments just toggles the Autofilter arrow on/off, and you loose your criteria.
Try this code, it worked for me (Office 2003) ... I have a header in A1, followed by A2..A13 named as DRCTable, followed by a =SUM(DRCTable) in A14
edit 02-Jan-2010
(sorry I can't test ODBC from my holiday domicile so this part is tested only syntactically)
Sub fillTable()
Dim MySheet As Worksheet, MyRange As Range
Dim MyQRY As QueryTable, MyCONNECT As String, MySELECT As String ' added 02-Jan-2010
'initialize
Set MySheet = Sheets("Sheet1")
Set MyRange = Range("DRCTable")
MyCONNECT = "ODBC;..." ' added 02-Jan-2010
MySELECT = "SELECT * FROM DUAL" ' added 02-Jan-2010 .. noticed my Oracle past :) ??
Set MyQRY = ActiveSheet.QueryTables.Add(Connection:=MyCONNECT, _
Destination:=MyRange, _
Sql:=MySELECT)
' clean up
MySheet.AutoFilterMode = False
MyRange.ClearContents
' simulate Query removed 02-Jan-2010
' MyRange(1, 1) = 1 removed 02-Jan-2010
' MyRange(2, 1) = 2 removed 02-Jan-2010
' MyRange(3, 1) = 3 removed 02-Jan-2010
' MyRange(4, 1) = 4 removed 02-Jan-2010
' MyRange(5, 1) = 5 removed 02-Jan-2010
' added 02-Jan-2010
' BackgroundQuery = FALSE waits until query is executed
' = TRUE continues with VBA once connection to DB is made
MyQRY.BackgroundQuery = False ' set this to affect all subsequet refresh
' and don't use the bool in refresh except
' to override the setting
MyQRY.Refresh False ' the false sets BackgroundQuery for the individual refresh;
' there is no default on this param within the refresh method.
' If unspecified here the QueryTable.BackgroundQuery property
' is examined
' select data range plus header and filter
Range(MyRange.Offset(-1, 0), MyRange(12, 1)).AutoFilter _
Field:=1, Criteria1:="<>"
End Sub
Hope that helps
Good luck MikeD