Excel 2013 with vba:
I have 2 columns in Sheet1 Column A has NBA Players while Column B shows their Jersey Numbers. If I type 2 in txtNumber it will display Players with number 2 on their Jerseys. It works on that way, However I can't click or select the entry or data. I'm thinking that Listbox would be a better replacement for TextBox, however I just don't know how to use the listbox. Please help.
Screenshot
code:
Private Sub txtNumber_Change()
Dim mySheet As Worksheet 'declaring mySheet as the Worksheet...
Dim x
Dim i As Long
Dim str As String
Set mySheet = Sheets("Sheet1")
x = mySheet.Range("A1").CurrentRegion.Value
For i = 2 To UBound(x, 1)
If x(i, 2) = Val(txtNumber.Value) Then
If str = "" Then
str = x(i, 1)
Else
str = str & vbNewLine & x(i, 1)
End If
End If
Next i
If str <> "" Then
txtName.Value = str
Else
txtName.Value = "Match not found"
End If
End Sub
Assuming the name of the listbox is ListBox1 then you may try something like this...
Private Sub txtNumber_Change()
Dim mySheet As Worksheet 'declaring mySheet as the Worksheet...
Dim x, dict
Dim i As Long
Dim cnt As Long
Set mySheet = Sheets("Sheet1")
ListBox1.Clear
x = mySheet.Range("A1").CurrentRegion.Value
Set dict = CreateObject("Scripting.Dictionary")
If Application.CountIf(mySheet.Columns(2), txtNumber.Value) > 0 Then
For i = 2 To UBound(x, 1)
If x(i, 2) = Val(txtNumber.Value) Then
dict.Item(x(i, 1)) = ""
End If
Next i
ListBox1.List = dict.keys
Else
ListBox1.AddItem "Match not found"
End If
End Sub
Related
As a single-column listbox, this works and brings back all the data I need, however, upon making this a multi-column listbox, it throws me the error "Run-time error '381': Could not set the List property. Invalid property array index" - see code line ListBox1.List(1, 0) = MyArray(i, 1)
Columns are correctly shown when I add the incorrect List Property and I've tried adding the List Property where I think it should be, but it shows the whole list again and replaces the 2nd row with one of the correct search results, the 1st row never changes.
Main code is from How to filter listbox values based on a Textbox value and I've used the comment by #xris23 to amend into the multi-column listbox thus far.
Please help!
Sub CommandButton1_Click()
Dim i As Long, j As Long, rw As Long
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim ws As Excel.Worksheet
Dim rng As Range
Dim MyArray As Variant
Dim sPath As String
sPath = "U:\GroupEmailDataCut.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
On Error GoTo 0
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
End If
Set xlBook = xlApp.Workbooks.Open(sPath)
Set ws = xlBook.Sheets("GroupEmailDataCut")
Set rng = ws.Range("A2:D" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
MyArray = rng
With UserForm1.ListBox1
.Clear
.ColumnHeads = False
.ColumnCount = rng.Columns.Count
If ws.Range("A" & ws.Rows.Count).End(xlUp).Row > 1 And Trim(UserForm1.TextBox1.Value) <> vbNullString Then
MyArray = ws.Range("A2:D" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row).Value2
For i = LBound(MyArray) To UBound(MyArray)
For j = LBound(MyArray, 1) To UBound(MyArray, 1)
If InStr(1, MyArray(i, 1), Trim(UserForm1.TextBox1.Value), vbTextCompare) Then
UserForm1.ListBox1.AddItem
ListBox1.List(1, 0) = MyArray(i, 1) '<----Error is across ListBox1.List (MyArray is working as intended)
ListBox1.List(1, 1) = MyArray(i, 2)
ListBox1.List(1, 2) = MyArray(i, 3)
ListBox1.List(1, 3) = MyArray(i, 4)
End If
Next
Next
End If
.List = MyArray
If UserForm1.ListBox1.ListCount = 1 Then UserForm1.ListBox1.Selected(0) = True
End With
End Sub
There are several points to observe to make the command button event readable or even runnable:
Don't address controls by referencing the Userform's default instance (returning the public members of that object),
reference instead the current instance starting either with the Me. qualifier or simply by naming the userform control alone. Understand the Userform (class) code behind as sort of pattern which is blue-printed to the current instance(s).
You are using .AddItem to fill a listbox with items (which is okay for e.g. 4 columns); consider, however that this method automatically builds 10 list columns, but not less or more; this can be avoided .. a) by assigning an entire 2-dim array to the .List (or .Column) property or .. b) by a workaround assigning an empty array plus immediate clearing which allows .AddItem also for greater column numbers (integrated in section 2a)
.List indices are zero-based, i.e. they start with 0 whereas the datafield array with its row and column indices is one-based: .List(cnt, c - 1) = data(r, c) - See section 2b)
Furthermore I separated the check for findings into a help function IsFound(), integrated list assignments into loops and tried to make code more readable by some other intermediate variable declarations.
Private Sub CommandButton1_Click()
'~~~~~~~~~~~~~~
'1) Define data
'~~~~~~~~~~~~~~
'1a)Define search string
Dim srch As String: srch = Trim(Me.TextBox1.Value)
'1b)Define data range
Dim ws As Worksheet: Set ws = Tabelle1
Dim lastRow As Long: lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Dim rng As Range: Set rng = ws.Range("A2:D" & lastRow)
'1c)Provide for possible exit
If rng.Row < 1 Or srch = vbNullString Then Exit Sub
'1d)Get 1-based 2-dim datafield array
Dim data() As Variant: data = rng.Value
'~~~~~~~~~~~~~~
'2) Fill ListBox
'~~~~~~~~~~~~~~
With Me.ListBox1
'2a)Set listbox properties & clear list
.ColumnHeads = False
.MultiSelect = fmMultiSelectMulti
'Provide for ColumnCount > 10
Dim ColCnt As Long: ColCnt = rng.Columns.Count
.ColumnCount = ColCnt
If ColCnt > 10 Then
Dim tmp(): ReDim tmp(1 To 1, 1 To ColCnt)
.List = tmp
End If
.Clear ' clear the ListBox
'2b)Loop through rows & add findings to list
Dim r As Long, c As Long, cnt As Long
For r = LBound(data) To UBound(data) ' 1 ..
If IsFound(srch, data, r) Then ' << help function IsFound()
.AddItem ' add item
For c = LBound(data, 2) To UBound(data, 2)
.List(cnt, c - 1) = data(r, c) '<< .List is zero-based!
Next
cnt = cnt + 1 ' increment counter
End If
Next
If .ListCount = 1 Then .Selected(0) = True
End With
End Sub
Help function IsFound()
Function IsFound(srch As String, arr, ByVal r As Long) As Boolean
'Purp.: check if search string is found in given 2-dim array row
Dim c As Long ' column index
For c = LBound(arr, 2) To UBound(arr, 2)
If InStr(1, arr(r, c), srch, vbTextCompare) Then
IsFound = True ' positive function result
Exit For ' one finding suffices
End If
Next
End Function
Further links
You'll find an outstanding article giving you some insight at UserForm1.Show?
Treating the different show modes you might be interested also in Destroy a modeless Userform instance properly
Assigning word document lines of text to an array to then print into an excel column. I want to print each item in array to it's own cell.
Currently, all the items are storying correctly into the array, but it's only printing the first item over and over Action
Code:
Option Explicit
Sub ParaCopy()
Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("Word.Application")
Set wDoc = wApp.Documents.Open("J:\Data Dictionary.docx", ReadOnly:=True)
Dim wPara As Word.Paragraph
Dim arr() As Variant
Dim i As Long
i = 0
For Each wPara In wDoc.Paragraphs
If wPara.Range.Words.Count > 1 Then
ReDim Preserve arr(i)
arr(i) = wPara.Range
End If
i = i + 1
Next wPara
For i = LBound(arr) To UBound(arr)
[a1].Resize(UBound(arr) + 1) = arr
Next i
End Sub
EDIT: Need to separate each block of text separated by a space (outlined in blue) to this
Create a 2D array with one column and load that:
Option Explicit
Sub ParaCopy()
Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("Word.Application")
Set wDoc = wApp.Documents.Open("J:\Data Dictionary.docx", ReadOnly:=True)
Dim wPara As Word.Paragraph
Dim arr() As Variant
ReDim arr(1 To wDoc.Paragraphs.Count, 1 To 1)
Dim i As Long
i = 1
For Each wPara In wDoc.Paragraphs
If wPara.Range.Words.Count > 1 Then
arr(i, 1) = wPara.Range
i = i + 1
End If
Next wPara
[a1].Resize(UBound(arr) + 1) = arr
End Sub
Copy Word Paragraphs to Excel Cells Using an Array
The number of rows of the array is wDoc.Paragraphs.Count which may differ from r (the 'actual count') hence you have to use r with Resize, and not wDoc.Paragraphs.Count or UBound(Data, 1).
Don't forget to Close the Document and Quit the App.
The first solution is early-bound and needs the library reference. When using it, just use
Set wApp = New Word.Application.
The second solution is late-bound and doesn't need the library reference. Also, it has been 'stripped off' the document and application variables (not necessary, you can declare them As Object).
Option Explicit
' e.g. Tools>References>Microsoft Word 16.0 Object Library
Sub ParaCopy()
Const FilePath As String = "J:\Data Dictionary.docx"
Dim wApp As Word.Application: Set wApp = Set wApp = New Word.Application
Dim wDoc As Word.Document: Set wDoc = wApp.Documents.Open(FilePath, , True)
Dim Data As Variant: ReDim Data(1 To wDoc.Paragraphs.Count, 1 To 1)
Dim wPara As Word.Paragraph
Dim r As Long
For Each wPara In wDoc.Paragraphs
If wPara.Range.Words.Count > 1 Then
r = r + 1
Data(r, 1) = wPara.Range
End If
Next wPara
wDoc.Close False
wApp.Quit
[a1].Resize(r) = Data
End Sub
Sub ParaCopyNoReference()
Const FilePath As String = "J:\Data Dictionary.docx"
With CreateObject("Word.Application")
With .Documents.Open(FilePath, , True)
Dim Data As Variant: ReDim Data(1 To .Paragraphs.Count, 1 To 1)
Dim wPara As Object
Dim r As Long
For Each wPara In .Paragraphs
If wPara.Range.Words.Count > 1 Then
r = r + 1
Data(r, 1) = wPara.Range
End If
Next wPara
.Close False
End With
.Quit
End With
[a1].Resize(r) = Data
End Sub
I've got a sub representing a commandbutton of my userform, this userform has the perpose of listing (in a listbox) all unique items found in a column of a two-dimensional array. At frst I would like to implant an extra variable to hold and thus represent the number of times the unique item appears in the array. Secondly I would like the (Unique) items listed as:
Unique item 1 (number of appearances).
Example 1 (23)
Example 2 (39)
Example 3 (101)
Example 4 (9)
...
Example n (#)
Here is the code, can some body help me out?
Private Sub CommandButton5_Click()
Dim ws As Worksheet
Dim dictUnq As Object
Dim UnqList() As String
Dim aData As Variant
Dim vData As Variant
Dim pData As Variant
Dim i As Variant
Dim PrintString1() As String
i = 1
Set ws = ActiveWorkbook.Sheets("Sheet3")
Set dictUnq = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.EnableEvents = False
With ws.Range("G2", ws.Cells(ws.Rows.Count, "G").End(xlUp))
If .Row < 2 Then Exit Sub 'No data
If .Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = .Value
Else
aData = .Value
End If
End With
SBI_Omschrijving.ListBox1.Clear
For Each vData In aData
If Len(vData) > 0 Then
If Not dictUnq.exists(vData) Then dictUnq.Add vData, vData
End If
Next vData
Debug.Print dictUnq(vData)
SBI_Omschrijving.ListBox1.List = dictUnq.keys
MsgBox "Unique findings: " & dictUnq.Count
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Use a dictionary to store the count? This demonstrates the principle. Note in your example I think you may only be adding one column G so I don't know of you intended more?
Sub test()
Dim myArray()
myArray = ActiveSheet.Range("A1").CurrentRegion.Value
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = LBound(myArray, 1) To UBound(myArray, 1) 'Depending on column of interest. Loop that
If Not dict.Exists(myArray(i, 1)) Then
dict.Add myArray(i, 1), 1
Else
dict(myArray(i, 1)) = dict(myArray(i, 1)) + 1
End If
Next i
Dim key As Variant
For Each key In dict.keys
Debug.Print key & "(" & dict(key) & ")"
Next key
End Sub
Your example might be something like (can't test dictionary on a mac I'm afraid so coding in my head)
Sub test()
Dim aData()
Dim ws As Worksheet
Dim targetRange As Range
Dim lastRow As Long
Set ws = ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
If lastRow = 1 Then Exit Sub
Set targetRange = ws.Range("G2:G" & lastRow)
If targetRange.Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = targetRange.Value
Else
aData = targetRange.Value2
End If
Dim dictUnq As Object
Set dictUnq = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = LBound(aData, 1) To UBound(aData, 1) 'Depending on column of interest. Loop that
If Not dictUnq.Exists(aData(i, 1)) Then
dictUnq.Add aData(i, 1), 1
Else
dictUnq(aData(i, 1)) = dictUnq(aData(i, 1)) + 1
End If
Next i
Dim key As Variant
For Each key In dictUnq.keys
Debug.Print key & "(" & dictUnq(key) & ")"
Next key
End Sub
another possibility
Option Explicit
Private Sub CommandButton5_Click()
Dim dictUnq As Object
Set dictUnq = CreateObject("Scripting.Dictionary")
Dim cell As Range
With ActiveWorkbook.Sheets("Sheet3")
For Each cell In .Range("G2", .Cells(.Rows.Count, "G").End(xlUp))
dictUnq(cell.Value) = dictUnq(cell.Value) + 1
Next
End With
If dictUnq.Count = 0 Then Exit Sub
Dim key As Variant
With SBI_Omschrijving.ListBox1
.Clear
.ColumnCount = 2
For Each key In dictUnq.keys
.AddItem key
.List(.ListCount - 1, 1) = dictUnq(key)
Next
End With
MsgBox "Unique findings: " & dictUnq.Count
End Sub
The code below removes values and indexes from array. I am wondering on how to stop the code once the array index gets too less than 0. The code currently breaks at this point, and I am looking at ways on trying to handle this.
Dim ws As Worksheet
Dim cmbbox() As Variant 'or String
Private Sub btnUndo_Click()
Dim idx As Integer
'idx = UBound(cmbbox) - 1
If Not Len(Join(cmbbox, "")) = 0 Then 'if your array is not empty remove the last value from it
ReDim Preserve cmbbox(UBound(cmbbox) - 1)
'cmbbox(0) = cbDepartmentNotes.Value
'MsgBox (idx)
Else 'if your array is empty redim your array and add value from combobox
MsgBox ("Please select your note")
'ReDim Preserve cmbbox(UBound(cmbbox) + 1)
'cmbbox(UBound(cmbbox)) = cbDepartmentNotes.Value
End If
'MsgBox "You selected Item : " & cmbbox(UBound(cmbbox))
'ListBox1.List = cmbbox
txtDepartmentNoteTemplate.Text = Join(cmbbox, ", ")
End Sub
Private Sub UserForm_Initialize()
Dim rngDepartment As Range
Set ws = Worksheets("Sheet1")
'Populate Department combo box.
For Each rngDepartment In ws.Range("Departments")
cbDepartment.AddItem rngDepartment.Value
Next rngDepartment
UserForm1.cbDepartmentNotes.Enabled = False
UserForm1.txtDepartmentNoteTemplate.Enabled = False
End Sub
Private Sub CommandButton1_Click() ' adds value to array and displays them in text box
If Len(Join(cmbbox, "")) = 0 Then 'if your array is empty add the first value from combobox to it
ReDim cmbbox(0)
cmbbox(0) = cbDepartmentNotes.Value
Else 'if your array is not empty redim your array and add value from combobox
ReDim Preserve cmbbox(UBound(cmbbox) + 1)
cmbbox(UBound(cmbbox)) = cbDepartmentNotes.Value
End If
'MsgBox "You selected Item : " & cmbbox(UBound(cmbbox))
'ListBox1.List = cmbbox
txtDepartmentNoteTemplate.Text = Join(cmbbox, ", ")
End Sub
Private Sub cbDepartment_Change() 'combo box value display function
displayNote
End Sub
Private Sub cbDepartmentNotes_Change()
txtDepartmentNoteTemplate.Enabled = True
End Sub
Function displayNote() As String
Dim rngDepartmentNote As Range
Dim x As String
Set ws = Worksheets("Sheet1")
If cbDepartment.Value = "IT" Then
cbDepartmentNotes.Clear
For Each rngDepartmentNote In ws.Range(Cells(3, "A"), Cells(3, "A").End(xlDown))
cbDepartmentNotes.Enabled = True
cbDepartmentNotes.AddItem rngDepartmentNote.Value
x = cbDepartmentNotes.Value
displayNote = x
Next rngDepartmentNote
ElseIf cbDepartment.Value = "PST" Then
cbDepartmentNotes.Clear
For Each rngDepartmentNote In ws.Range(Cells(3, "B"), Cells(3, "B").End(xlDown))
cbDepartmentNotes.Enabled = True
cbDepartmentNotes.AddItem rngDepartmentNote.Value
txtDepartmentNoteTemplate.Enabled = True
x = cbDepartmentNotes.Value
displayNote = x
Next rngDepartmentNote
End If
End Function
I've been searching for an answer to this, but I haven't been able to find anything specific enough to fill the gap in my VBA knowledge.
I'm putting two lists of data into arrays to be compared using a modified version of the code found here
(I'll post it below).
HOWEVER, I don't want to input the whole cell into the array to be compared with the second array. For instance, if the cell in the first sheet says "Company, LLC", I would like to only search "Company". I have some code that does this:
s = rCell.Value
indexofthey = InStr(1, s, ",")
aftercomma = Right(s, Len(s) - indexofthey + 1)
celld = Left(s, Len(s) - Len(aftercomma))
The code I need to somehow work this into (copied from the answer to the question I linked above) is this:
Option Explicit
Private Sub cmdCompare2to1_Click()
Dim sheet1 As Worksheet, sheet2 As Worksheet, sheet3 As Worksheet
Dim lngLastR As Long, lngCnt As Long
Dim var1 As Variant, var2 As Variant, x
Dim rng1 As Range, rng2 As Range
Set sheet1 = Worksheets(1)
Set sheet2 = Worksheets(2)
Set sheet3 = Worksheets(3) ' assumes sheet3 is a blank sheet in your workbook
Application.ScreenUpdating = False
'let's get everything all set up
'sheet3 column headers
sheet3.Range("A1:B1").Value = Array("in1Not2", "in2Not1")
'sheet1 range and fill array
With sheet1
lngLastR = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng1 = .Range("A1:A" & lngLastR)
var1 = rng1
End With
'sheet2 range and fill array
With sheet2
lngLastR = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng2 = .Range("A1:A" & lngLastR)
var2 = rng2
End With
'first check sheet1 against sheet2
On Error GoTo NoMatch1
For lngCnt = 1 To UBound(var1)
x = Application.WorksheetFunction.Match(var1(lngCnt, 1), rng2, False)
Next
'now check sheet2 against sheet1
On Error GoTo NoMatch2
For lngCnt = 1 To UBound(var2)
x = Application.WorksheetFunction.Match(var2(lngCnt, 1), rng1, False)
Next
On Error GoTo 0
Application.ScreenUpdating = True
Exit Sub
NoMatch1:
sheet3.Range("A" & sheet3.Rows.Count).End(xlUp).Offset(1) = var1(lngCnt, 1)
Resume Next
NoMatch2:
sheet3.Range("B" & sheet3.Rows.Count).End(xlUp).Offset(1) = var2(lngCnt, 1)
Resume Next
End Sub
Assuming you do not want to change the values in your cells you will need to loop through the arrays. You can use a proc like this:
Sub RemoveUnwantedText(ByRef theArray As Variant)
Dim theValue As String
Dim i As Long
Dim indexOfComma As Integer
' array is created from single-column range of cells
' and so has 2 dimensions
For i = LBound(theArray, 1) To UBound(theArray, 1)
theValue = CStr(theArray(i, 1))
indexOfComma = InStr(1, theValue, ",")
If indexOfComma > 0 Then
theValue = Trim(Left(theValue, indexOfComma - 1))
End If
theArray(i, 1) = theValue
Next i
End Sub
Paste this into the same module as your code. In your code, before you do any comparison, add these calls:
RemoveUnwantedText var1
RemoveUnwantedText var2