Hi All
Here is my own code to do what Jim wants :-
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Populate a multicolumn Listbox (with >10 columns) from an Excel range
' Derek Turner February 2012
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub UserForm_Initialize()
Const FIND_I = "MPR0010"
Const FIND_J = "T1"
Const COLUMN_I = 9
Const COLUMN_J = 10
Const LISTBOXCOLUMNS = 17
Const TITLEROW = 1
Dim vSourceArray As Variant, vSubsetArray() As Variant
Dim vSubsetRow(1 To LISTBOXCOLUMNS), clxSubsetRows As New Collection
Dim nSourceRow As Long, nSubsetRow As Long, nSourceRowCount As Long, nListBoxColumn As Long
'
vSourceArray = Worksheets("Gages").Range("a1").CurrentRegion.Value
nSourceRowCount = UBound(vSourceArray)
For nSourceRow = 1 To nSourceRowCount
If nSourceRow =
TITLEROW _
Or (vSourceArray(nSourceRow, COLUMN_I) = FIND_I _
And vSourceArray(nSourceRow, COLUMN_J) = FIND_J) Then
For nListBoxColumn = 1 To LISTBOXCOLUMNS
vSubsetRow(nListBoxColumn) = vSourceArray(nSourceRow, nListBoxColumn)
Next nListBoxColumn
clxSubsetRows.Add vSubsetRow()
End If
Next nSourceRow
With clxSubsetRows
ReDim vSubsetArray(1 To .Count, 1 To LISTBOXCOLUMNS)
For nSubsetRow = 1 To .Count
For nListBoxColumn = 1 To LISTBOXCOLUMNS
vSubsetArray(nSubsetRow, nListBoxColumn) = .Item(nSubsetRow)(nListBoxColumn)
Next nListBoxColumn
Next nSubsetRow
End With
With ListBox1
.ColumnCount = LISTBOXCOLUMNS
.ColumnWidths = "100;80;50;50;50;50;50;100;60;50;50;50;50;50;05;05;50"
.List = vSubsetArray
End With
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
To test this you need to put random stuff into a range of 17 columns and as many rows as you like (I used 39,000) in a worksheet called "Gages", then populate a few cells in column I with "MPR0010" and then "T1" in a few less cells in the corresponding rows in column J. Of course also you need Listbox1 in the Userform.
This code is more complicated than expected because of yet another VBA bug. The Listbox control does not allow you fill more than 10 columns usingthe .List(.ListCount - 1, nColumn)method that I used in my previous post. It errors. This is undocumented in the Help, so is a bug.
My first approach was to make a subset array from the matching rows but the problem there is that you can only Redim the rightmost dimension in a Redim statement (columns being in the rightmost). In the past I have coped with this with a double transpose method but I did not want to increase the number of code lines. I also tried a method that involved putting a large mainly blank subset array into the Listbox and then in a loop using RemoveItem to delete empty rows but this took too long (10 seconds for 39,000 rows)
Therefore the method I used puts individual matching rows into a Collection and then in the last stage unpacks them into a rectangular array which populates the List property of the Listbox. Collections expand and contract dynamically without Re-Dim-ing.
The code is written in a self documenting style. If anybody wants an explanation of any point I will be pleased to oblige. By the way I tested this with 480 columns. It works. I don't know how anybody could use a Listbox with 480 columns (let alone 17, Microsoft thinks 10 is too many) but it works with only a minor pause.
Comments invited please.
Regards
Derek Turner +++
From:JIMNEELY <jimneely@yahoo.com>
>
>To: ExcelVBA@yahoogroups.com
>Sent: Sunday, 26 February 2012, 4:28
>Subject: [ExcelVBA] Re: LISTBOX
>
>
>
>wow I fixed my problem. all i did was to start macro recording and went though the steps i wanted the program to do and it works here is the code.
>
>Private Sub UserForm_Initialize()
>'Author : Jim Neely
>'Macro Purpose: To populate a listbox with data from
>' a worksheet range
>Application.ScreenUpdating = False
>Sheets("Gages").Select
>Range("A2").Select
>Selection.AutoFilter
>ActiveSheet.Range("$A$1:$Q$905").AutoFilter Field:=9, Criteria1:="MR0008"
>ActiveSheet.Range("$A$1:$Q$905").AutoFilter Field:=10, Criteria1:="T1"
>Range("A1:Q905").Select
>Selection.Copy
>'Workbooks.Open Filename:="C:\Users\Lori\Desktop\awnc\ScratchWB.xlsx"
>Sheets("Sheet3").Select
>Range("A1").Select
>ActiveSheet.Paste
>Range("A2").Select
>'Windows("Press Area - Master Gage File and Map.xlsm").Activate
>Sheets("Gages").Select
>Range("A78").Select
>Application.CutCopyMode = False
>Selection.AutoFilter
>Range("A2").Select
>'Windows("ScratchWB.xlsx").Activate
>Sheets("Sheet3").Select
>Dim lbtarget As msforms.ListBox
>Dim rngSource As Range
>'Set reference to the range of data to be filled
>Set rngSource = Worksheets("sheet3").Range("A1:Q500")
>'Fill the listbox
>Set lbtarget = Me.ListBox3
>With lbtarget
>'Determine number of columns
>.ColumnCount = 17
>'Set column widths
>.ColumnWidths = "100;80;50;50;50;50;50;100;60;50;50;50;50;50;05;05;50"
>'Insert the range of data supplied
>.List = rngSource.Cells.Value
>End With
>'Dim savechanges As Boolean
>'savechanges = False
>'Application.ActiveWindow.Close (savechanges)
>Sheets("Map").Select
>Application.ScreenUpdating = True
>
>End Sub
>
>--- In ExcelVBA@yahoogroups.com, Derek Turner <g4swy@...> wrote:
>>
>> Hi Jim
>>
>> I am not sure about the problem as described in your later post, but this is a more simple way of doing what I think you are trying to achieve in your code below.
>>
>> Private Sub UserForm_Initialize()
>> Dim nRow As Long
>> Dim vArray As Variant
>> Const LOOKFOR = "PR0010"
>> '
>> Â Â vArray = Worksheets("Gages").Range("i1:k39000").Value
>> Â Â With ListBox1
>>
>> Â Â Â Â .ColumnCount = 3
>> Â Â Â Â .ColumnWidths = "50"
>> Â Â Â Â For nRow = 1 To UBound(vArray)
>> Â Â Â Â Â Â If vArray(nRow, 1) = LOOKFOR Then
>> Â Â Â Â Â Â Â Â .AddItem vArray(nRow, 1)
>> Â Â Â Â Â Â Â Â .List(.ListCount - 1, 1) = vArray(nRow, 2)
>> Â Â Â Â Â Â Â Â .List(.ListCount - 1, 2) = vArray(nRow, 3)
>> Â Â Â Â Â Â End If
>> Â Â Â Â Next nRow
>> Â Â End With
>> End Sub
>>
>>
>> It assumes you have a Listbox1 in the UserForm and is looking for a match in column i (which I populated with an arbitrary 38,000 random rows to test the speed), and picks up the items in columns j and k for the multi-column listbox. Notice it does not error if you set the ColumnCount to 2, it just ignores the item.
>>
>> Regards.
>>
>> Derek +++
>>
>> Â
>>
>>
>>
>>
>>
>>
>> >________________________________
>> > From: JIMNEELY <jimneely@...>
>> >To: ExcelVBA@yahoogroups.com
>> >Sent: Wednesday, 22 February 2012, 19:59
>> >Subject: [ExcelVBA] Re: LISTBOX
>> >
>> >
>> >Â
>> >
>> >
>> >--- In ExcelVBA@yahoogroups.com, "JIMNEELY" <jimneely@> wrote:
>> >>
>> >> I want a listbox to show items from a spreadsheet. The items have to be certain items so I was thinking a FIND would do the trick. but my main question to the group is this possible.
>> >>
>> >This might help. I am trying to fill a listbox with 3 columns based on a one find item. so i look at all "PR0008" and store the 3 columns in a array to later display in a listbox. Here is the code so far. It does not store the "DEPT" but instead the count.
>> >Private Sub UserForm_Initialize()
>> >Dim lb As msforms.ListBox
>> >Dim rcArray() As String
>> >Dim Dept As Integer
>> >With Worksheets("Gages").Range("I2:I25")
>> >Set D = .Find("PR0010", LookIn:=xlValues)
>> >firstaddress = D.Address
>> >Set D = .FindNext(D)
>> >While D.Address <> firstaddress
>> >Dept = Dept + 1
>> >MsgBox Dept
>> >MsgBox D
>> >ReDim Preserve rcArray(1 To Dept)
>> >rcArray(D) = D
>> >Set D = .FindNext(D)
>> >Wend
>> >End With
>> >
>> >'Place the array in the listbox
>> >Set lb = Me.ListBox1
>> >With lb
>> >.ColumnCount = 1
>> >.ColumnWidths = "50"
>> >.List = rcArray
>> >End With
>> >End Sub
>> >
>> >
>> >
>> >
>> >
>>
>> [Non-text portions of this message have been removed]
>>
>
>
>
>
>
[Non-text portions of this message have been removed]
Be sure to check out TechTrax Ezine for many, free Excel VBA articles! Go here: http://www.mousetrax.com/techtrax to enter the ezine, then search the ARCHIVES for EXCEL VBA.
----------------------------------
Visit our ExcelVBA group home page for more info and support files:
http://groups.yahoo.com/group/ExcelVBA
----------------------------------
More free tutorials and resources available at:
http://www.mousetrax.com
----------------------------------
Tidak ada komentar:
Posting Komentar