I am trying to cycle through a number of worksheets, then listbox controls within each worksheet and populate them with my code. I am using the code below:
Dim sh As Worksheet
Dim obj As OLEObject
Dim lst As MSForms.ListBox
Dim idx As Long
For idx = 1 To ThisWorkbook.Worksheets.Count
Set sh = ThisWorkbook.Worksheets(idx)
For Each obj In sh.OLEObjects
If obj.progID = "Forms.ListBox.1" Then
Set lst = obj
If (lst.Name = "lst1") Then
Call PopulateSimple(lst, "Table1")
End If
End If
Next
Next idx
This seems to fail unfortunately when I set the listbox to the object. Any idea as to how I can achieve looping through all the listboxes in different worksheets and then populating them?
Try this
Sub Sample()
Dim sh As Worksheet
Dim obj As OLEObject
Dim idx As Long
For idx = 1 To ThisWorkbook.Worksheets.Count
Set sh = ThisWorkbook.Worksheets(idx)
For Each obj In sh.OLEObjects
If TypeOf obj.Object Is MSForms.ListBox Then
If (obj.Name = "lst1") Then
Call PopulateSimple(obj, "Table1")
End If
End If
Next
Next idx
End Sub
Explanation: You are getting that error because obj is declared as OLEObject and lst as MSForms.ListBox and hence a type mismatch.
can't you use the obj in your call to PopulateSimplesince you know it is a ListBox:
Dim sh As Worksheet
Dim obj As OLEObject
Dim lst As MSForms.ListBox
Dim idx As Long
For idx = 1 To ThisWorkbook.Worksheets.Count
Set sh = ThisWorkbook.Worksheets(idx)
For Each obj In sh.OLEObjects
If obj.progID = "Forms.ListBox.1" Then
'Set lst = obj
If (obj.Name = "lst1") Then
Call PopulateSimple(obj, "Table1")
End If
End If
Next
Next idx
simplest way (moved from comment):
In my opinion you need to change
Dim lst as MSForms.ListBox
into
Dim lst as OLEObject
and that is all...
Related
I needed to collect a unique list of text from a matrix, ("J19:BU500" in my case which contains duplicates) and paste it in a column (column DZ in my case) in the same sheet.
I need to loop this for multiple sheets in the same workbook. I'm new to VBA and got this code from internet and customized a bit to my requirement. But I have two problems with the code:
When the matrix is empty in say sheet 5, the code runs fine upto sheet 4 and throws a runtime error at sheet5 and stops without looping further to next sheets.
Also, I actually wanted the unique list to start at Cell "DZ10". If I do that, the number of unique list reduces by 10. For say there are 25 uniques, only 15 gets pasted starting from cell "DZ10" whereas all 25 gets pasted from cell "DZ1".
Code:
Public Function CollectUniques(rng As Range) As Collection
Dim varArray As Variant, var As Variant
Dim col As Collection
If rng Is Nothing Or WorksheetFunction.CountA(rng) = 0 Then
Set CollectUniques = col
Exit Function
End If
If rng.Count = 1 Then
Set col = New Collection
col.Add Item:=CStr(rng.Value), Key:=CStr(rng.Value)
Else
varArray = rng.Value
Set col = New Collection
On Error Resume Next
For Each var In varArray
If CStr(var) <> vbNullString Then
col.Add Item:=CStr(var), Key:=CStr(var)
End If
Next var
On Error GoTo 0
End If
Set CollectUniques = col
End Function
Public Sub WriteUniquesToNewSheet()
Dim wksUniques As Worksheet
Dim rngUniques As Range, rngTarget As Range
Dim strPrompt As String
Dim varUniques As Variant
Dim lngIdx As Long
Dim colUniques As Collection
Dim WS_Count As Integer
Dim I As Integer
Set colUniques = New Collection
WS_Count = ActiveWorkbook.Worksheets.Count
For I = 3 To WS_Count
Sheets(I).Activate
Set rngTarget = Range("J19:BU500")
On Error GoTo 0
If rngTarget Is Nothing Then Exit Sub '<~ in case the user clicks Cancel
Set colUniques = CollectUniques(rngTarget)
ReDim varUniques(colUniques.Count, 1)
For lngIdx = 1 To colUniques.Count
varUniques(lngIdx - 1, 0) = CStr(colUniques(lngIdx))
Next lngIdx
Set rngUniques = Range("DZ1:DZ" & colUniques.Count)
rngUniques = varUniques
Next I
MsgBox "Finished!"
End Sub
Any help is highly appreciated. Thankyou
You need to select the correct amount of cells to fill in all data from an array. Like Range("DZ10").Resize(RowSize:=colUniques.Count)
That error probably means that colUniques is nothing and therefore has no .Count. So test if it is Nothing before you use it.
You will end up with something like below:
Public Sub WriteUniquesToNewSheet()
Dim wksUniques As Worksheet
Dim rngUniques As Range, rngTarget As Range
Dim strPrompt As String
Dim varUniques As Variant
Dim lngIdx As Long
Dim colUniques As Collection
Dim WS_Count As Integer
Dim I As Integer
Set colUniques = New Collection
WS_Count = ActiveWorkbook.Worksheets.Count
For I = 3 To WS_Count
Sheets(I).Activate
Set rngTarget = Range("J19:BU500")
'On Error GoTo 0 'this is pretty useless without On Error Resume Next
If rngTarget Is Nothing Then Exit Sub 'this is never nothing if you hardcode the range 2 lines above (therefore this test is useless)
Set colUniques = CollectUniques(rngTarget)
If Not colUniques Is Nothing Then
ReDim varUniques(colUniques.Count, 1)
For lngIdx = 1 To colUniques.Count
varUniques(lngIdx - 1, 0) = CStr(colUniques(lngIdx))
Next lngIdx
Set rngUniques = Range("DZ10").Resize(RowSize:=colUniques.Count)
rngUniques = varUniques
End If
Next I
MsgBox "Finished!"
End Sub
I have the code below which colors bubble chart data points based on the data label text. I'm not sure why I am keeping an "Invalid paramter error"
Edited for more clarity.
The code loops through a spreadsheet where I have data label filter critieria stored(see image attached). It will copy a pre-made bubble graph and color it. variable f loops between variables a and c, and based on the values in between these two variables, the bubble chart will color if it matches. If not, it moves past it. After bubbles are colored, it moves on to the next variation of coloring.
Sub Slide31()
Dim rngx As Range
Dim rngy As Range
Dim rngz As Range
Dim ws3 As Worksheet
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim icnt As Long
Dim lastrow As Long
Dim k As Long
Dim icounter As Long
Dim a As Long
Dim c As Long
Dim b As Long
Dim d As Variant
Dim Chart As ChartObject
Dim PPapp As Object
Dim PPTDoc As PowerPoint.Presentation
Dim PPT As PowerPoint.Application
Dim PPpres As Object
Dim pptSlide As PowerPoint.Slide
Dim ppslide As Object
Dim e As Long
Dim f As Long
Dim filename As String
Dim filename2 As String
Dim x As Variant
Dim y As Variant
Dim z As Variant
Dim ch As Chart
Dim s As Series
Dim iPoint As Long
Dim nPoint As Long
Set ws = Worksheets("Reference")
Set ws1 = Worksheets("Bubbles")
Set ws2 = Worksheets("Slide 31")
Set ws3 = Worksheets("Bubble Reference")
ws2.Activate
'ws2.Range("h:h").NumberFormat = "0.00%"
lastrow = ws2.Cells(Rows.Count, "b").End(xlUp).Row
For icounter = 1 To lastrow
For icnt = 51 To 79
If ws2.Cells(icounter, 2) = ws.Cells(icnt, 3) Then
d = ws.Cells(icnt, 3)
a = icounter + 2
b = icounter + 2
c = icounter + 11
filename = ""
filename2 = ""
ws3.ChartObjects(1).Copy
ws2.Paste
Set ch = ActiveChart
Set s = ch.SeriesCollection(1)
For f = a To c
nPoint = s.Points.Count
For iPoint = 1 To nPoint
If ws2.Cells(f, 8) = s.Points(iPoint).DataLabel.Text Then
s.Points(iPoint).Format.Fill.ForeColor.RGB = RGB(192, 0, 0)
End If
Next iPoint
Next f
End If
Next icnt
Next icounter
Point object doesn't have an Interior property. (Edit: Yes, it actually does even though the Dox and the Intellisense do not seem to expose it).
(Point object reference | Excel Reference)
The specific error you're getting (1004, "Invalid parameter error") is akin to Index Out of Bounds, you're somehow trying to index the Points collection in an invalid way, though I'm not sure how this is possible. You can easily get this error if you try s.Points(0) or s.Points(s.Points.Count+1), for instance.
You could try this alternative approach:
Dim pt as Point
For Each pt in s.Points
If ws2.Cells(f, 8) = pt.DataLabel.Text Then
pt.Format.Fill.ForeColor.RGB = RGB(192, 0, 0)
End If
Next
I have a pivot table and the following VBA which displays a msgbox for the first row field, but I need it to go through all row fields displaying a message box for each one, can someone point me in the right direction, I cant seem to work out how to do it
Sub Piv()
Dim PvTable As PivotTable
Dim PvField As PivotField
Dim PvItem As PivotItem
Set PvTable = ActiveSheet.PivotTables("RawDataTable")
Set PvField = PvTable.RowFields(1)
With ws
For Each PvItem In PvField.PivotItems
MsgBox PvItem
Next
End With
End Sub
I can also get it to give me all the field headers, but not the data
Sub Piv()
Dim PvTable As PivotTable
Dim PvField As PivotField
Dim PvItem As PivotItem
Set PvTable = ActiveSheet.PivotTables("RawDataTable")
With ws
For Each PvField In PvTable.PivotFields
MsgBox PvField
Next
End With
End Sub
This is a fairly brute-force approach, and hopefully someone will come up with something more elegant, but we can read the details of the row fields into an array of arrays, and then run through this array in reverse index order:
Option Explicit
Sub Piv()
Dim PvTable As PivotTable
Dim PvField As PivotField
Dim PvItem As PivotItem
Dim dataArray() As Variant
Dim dummyArray() As Variant
Dim i As Long
Dim j As Long
Set PvTable = ActiveSheet.PivotTables("RawDataTable")
ReDim dataArray(1 To PvTable.RowFields.Count)
ReDim dummyArray(1 To PvTable.RowFields(1).PivotItems.Count)
For i = 1 To PvTable.RowFields.Count
dataArray(i) = dummyArray
For j = 1 To PvTable.RowFields(i).PivotItems.Count
dataArray(i)(j) = PvTable.RowFields(i).PivotItems(j)
Next j
Next i
For i = 1 To UBound(dataArray(1))
For j = 1 To UBound(dataArray)
MsgBox dataArray(j)(i)
Next j
Next i
End Sub
Goal
Import about 100+ lines of data into a worksheet. Quickly.
Current Problem
The Excel file isn't very large (not even 1MB). Although, we use this Excel file to communicate with SolidEdge which makes it very heavy.
At the moment, it takes about 60 seconds to populate the 100 lines of data. Don't get me wrong, that isn't very long. Whereas I tested it with a new and empty Excel file and it took less than 1 second to populate the data.
Code
Here's my code incase I did something stupid in there:
Private Sub PopulateExcel()
Dim xlApp As Excel.Application = Nothing
Dim xlWorkBooks As Excel.Workbooks = Nothing
Dim xlWorkBook As Excel.Workbook = Nothing
Dim xlWorkSheet As Excel.Worksheet = Nothing
Dim xlWorkSheets As Excel.Sheets = Nothing
Dim Proceed As Boolean = False
Dim RowIndex As Integer = 2
Dim counter As Integer = 0
xlApp = CType(Marshal.GetActiveObject("Excel.Application"), Excel.Application)
xlWorkBooks = xlApp.Workbooks
For Each wb As Excel.Workbook In xlWorkBooks
If wb.Name.Contains("301-AAAA-00X") Then
xlWorkBook = wb
xlWorkSheets = xlWorkBook.Sheets
Exit For
End If
Next
If xlWorkSheets IsNot Nothing Then
For x As Integer = 1 To xlWorkSheets.Count
xlWorkSheet = CType(xlWorkSheets(x), Excel.Worksheet)
If xlWorkSheet.Name = "ImportSheet" Then
Proceed = True
Exit For
End If
Runtime.InteropServices.Marshal.FinalReleaseComObject(xlWorkSheet)
xlWorkSheet = Nothing
Next
End If
If Proceed Then
tspbProgress.Value = 0
tspbProgress.Maximum = dic_Vars.Count
tspbProgress.Visible = True
For Each key As KeyValuePair(Of String, String) In dic_Vars 'Contains all my the data
tsslStatus.Text = "Populating Excel: " & key.Key & " | " & key.Value
xlWorkSheet.Cells(RowIndex, 2).value = key.Key
xlWorkSheet.Cells(RowIndex, 3).value = key.Value
RowIndex += 1
IncProg()
Next
tspbProgress.Visible = False
ReleaseComObject(xlWorkSheets)
ReleaseComObject(xlWorkSheet)
ReleaseComObject(xlWorkBook)
ReleaseComObject(xlWorkBooks)
ReleaseComObject(xlApp)
End If
End Sub
Private Sub ReleaseComObject(ByRef obj As Object)
Try
System.Runtime.InteropServices.Marshal.ReleaseComObject(obj)
obj = Nothing
Catch ex As Exception
obj = Nothing
End Try
End Sub
Conclusion
I was thinking about creating a new Excel file, importing the data there, and just doing a copy / paste to the real Excel file that we use.
Any suggestions?
Good thank you to Byron Wall who helped me find the answer. I now input my data using an array instead of iterating through each cell.
I create my array and populate it depending on how large my dictionary of variables is. I then create a new range using the Resize() method seen below.
Once that's done, everything is populated in an instant!
Dim arrNames(,) As String = New String(AscW(ChrW(dic_Vars.Count)), 1) {}
Dim arrValues(,) As String = New String(AscW(ChrW(dic_Vars.Count)), 1) {}
Dim i As Integer = 0
For Each key As KeyValuePair(Of String, String) In dic_Vars
arrNames(i, 0) = key.Key
arrValues(i, 0) = key.Value
i += 1
Next
If Proceed Then
Dim r As Microsoft.Office.Interop.Excel.Range = xlWorkSheet.Range("B2").Resize(arrNames.GetLength(0))
Dim r2 As Microsoft.Office.Interop.Excel.Range = xlWorkSheet.Range("C2").Resize(arrValues.GetLength(0))
r.Value2 = arrNames
r2.Value2 = arrValues
ReleaseComObject(xlWorkSheets)
ReleaseComObject(xlWorkSheet)
ReleaseComObject(xlWorkBook)
ReleaseComObject(xlWorkBooks)
ReleaseComObject(xlApp)
End If
I am trying to paste few images from one excel to another, but facing an issue in it. the images are overlapping on each other., and even the size is very small.Below is the code of what i have tried.
If Source = ESNAME Then
Dim shp As Microsoft.Office.Interop.Excel.Shape
Dim lCol As Integer = 0
Dim I As Integer = 1
'~~> Loop through all shapes and find the last col of the shape
For Each shp In WS.Shapes
If shp.BottomRightCell.Column > lCol Then _
lCol = shp.BottomRightCell.Column
With WS
'~~> Find actual last Row
Dim LastRow As Integer = I
Dim LastColumn As Integer = I
Dim str As String = "B" & I & "#"
'~~> Check if we have the correct last columnm
If LastColumn < lCol Then LastColumn = lCol
.Range(str.Replace("#", ":") & Split(.Cells(, LastColumn).Address, "$")(1) & LastRow).Copy()
Dim sheet As Microsoft.Office.Interop.Excel.Worksheet
sheet = Nothing
sheet = DW.Worksheets(1)
sheet.Paste()
End With
I = I + 1
Next
End If
Thanks in advance.
Let's say your Workbook1 looks like this
Try this code (TRIED AND TESTED in VS 2010 + OFFICE 2010)
Code
Imports Excel = Microsoft.Office.Interop.Excel
Public Class Form1
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
'~~> Define your Excel Objects
Dim xlApp As New Excel.Application
Dim xlWorkBook1 As Excel.Workbook = Nothing
Dim xlWorkBook2 As Excel.Workbook = Nothing
Dim xlWorkSheet1 As Excel.Worksheet = Nothing
Dim xlWorkSheet2 As Excel.Worksheet = Nothing
'~~> Display Excel
xlApp.Visible = True
'~~> Open relevant excel files and set your objects
xlWorkBook1 = xlApp.Workbooks.Open("C:\book1.xlsx")
xlWorkSheet1 = xlWorkBook1.Sheets("Sheet1")
xlWorkBook2 = xlApp.Workbooks.Open("C:\book2.xlsx")
xlWorkSheet2 = xlWorkBook2.Sheets("Sheet2")
Dim xlShp As Excel.Shape = Nothing
Dim xlShape As Excel.Shape = Nothing
For Each xlShp In xlWorkSheet1.Shapes
xlShp.Copy()
xlWorkSheet2.Paste(Destination:=xlWorkSheet2.Range("A1"))
Next
Dim col1 As New Point(10, 10)
Dim col2 As New Point(col1.X * 2 + xlWorkSheet2.Shapes(0).Width, 10)
Dim stdHeight As Integer = CType(xlWorkSheet2.Shapes(0), Excel.Shape).Height + 5
For i As Integer = 0 To xlWorkSheet2.Shapes.Count - 1 Step 2
xlShape = xlWorkSheet2.Shapes(i)
xlShape.Left = col1.X
xlShape.Top = col1.Y + i * stdHeight
xlShape = xlWorkSheet2.Shapes(i + 1)
xlShape.Left = col2.X
xlShape.Top = col2.Y + i * stdHeight
Next
'~~> Save the file
xlWorkBook2.Save()
'~~> Close the File
xlWorkBook1.Close (False)
xlWorkBook2.Close (False)
'~~> Quit the Excel Application
xlApp.Quit()
'~~> Clean Up
releaseObject (xlShp)
releaseObject (xlShape)
releaseObject (xlWorkSheet1)
releaseObject (xlWorkSheet2)
releaseObject (xlWorkBook1)
releaseObject (xlWorkBook2)
releaseObject (xlApp)
End Sub
'~~> Release the objects
Private Sub releaseObject(ByVal obj As Object)
Try
System.Runtime.InteropServices.Marshal.ReleaseComObject (obj)
obj = Nothing
Catch ex As Exception
obj = Nothing
Finally
GC.Collect()
End Try
End Sub
End Class
Workbook 2 Output