Im doing code where button 1 will get data from worksheet and store in array, and button 2 will print the array in worksheet and textbox.
Public arr As Variant
Private Sub UserForm_Click()
End Sub
Private Sub CommandButton1_Click()
arr = Range("B8:C17")
Range("B8:C17") = Clear
End Sub
Private Sub CommandButton2_Click()
Range("B8:C17") = arr
TextBox1.Text = arr
End Sub
Private Sub CommandButton3_Click()
Unload Me
End Sub
Everthing is fine excepet it does not print array in textbox. what is wrong here ?
So what you need to do is loop through your rows of array data and populate it one by one.
Firstly, you need to make sure to set Multiline to True in your textbox properties.
Then add this:
Private Sub CommandButton2_Click()
Range("B8:C17") = arr
Dim i As Long
For i = 1 To UBound(arr, 1)
Me.TextBox1.Text = Me.TextBox1.Text & arr(i, 1) & Chr(9) & arr(i, 2) & vbCr
Next i
End Sub
Note:
This will only work for 2 columns in the array. If you have more, you will need to add another & arr(i, x) to the line with x being the column number.
If you need an extra tab between the 2 columns, add another & Chr(9) to the line next to the already existing one.
See if that works for you.
Related
I have a simple UserForm with two Listboxes and two Textboxes that contain the value of the currently selected Listitem. I am having a bizarre bug where one of the boxes will not populate when the form loads. If I close the form and load it again, then the opposite box will not load. If I close and reload a third time, then it loads the first box but not the second again. Repeat ad nauseum.
First Load:
Second Load:
The code should have both Textboxes populated at startup. What is the source of this bug?
Private Sub UserForm_Initialize()
Dim i As Long
For i = 1 To 4
ListBox1.AddItem "Item A - " & i
Next i
ListBox1.ListIndex = 0
End Sub
Private Sub ListBox1_Change()
Dim i As Long
ListBox2.Clear
For i = 1 To 3
ListBox2.AddItem "Item B - " & i
Next i
ListBox2.ListIndex = 0
TextBox1.Value = ListBox1.Value
End Sub
Private Sub ListBox2_Change()
TextBox2.Value = ListBox2.Value
End Sub
This answer is from Yow3Ek as much as from anyone. This code runs as tested without error or previous problem. Thanks guys, I learned something today. It was firing on the clear.
Private Sub UserForm_Initialize()
Dim i As Long
For i = 1 To 4
Me.ListBox1.AddItem "Item A - " & i
Next i
Me.ListBox1.ListIndex = 0
End Sub
Private Sub ListBox1_Change()
Dim i As Long
Me.ListBox2.Clear
For i = 1 To 3
ListBox2.AddItem "Item B - " & i
Next i
Me.ListBox2.ListIndex = 0
Me.TextBox1.Value = Me.ListBox1.List(Me.ListBox1.ListIndex)
End Sub
Private Sub ListBox2_Change()
If Me.ListBox2.ListIndex = -1 Then Exit Sub
Me.TextBox2.Value = Me.ListBox2.List(Me.ListBox2.ListIndex)
End Sub
I have a code that counts the files in a folder if they contain a specific string on their name.
For example: If I want it to count the files with close on their name (Close_26_03_2003.csv).
Currently the code reads the value of a cell in the sheet and searches for that string in the file name with the (InStr function). Problem is I have to write the type of file in the cell.
What I am trying to do is create an user form, with three option buttons (open, close and cancel). For open it sets the string equal to open, and search for files that have it on their name (same as for close). Cancel ends the sub.
Problem is I don't know which code I have to use in the user form for this and don't know how to pass it to the code that counts files (I though about assigning it to a variable).
Code as is:
Sub CountFiles3()
Dim path As String, count As Integer, i As Long, var As Integer
Dim ws As Worksheet
Dim Filename As String
Dim FileTypeUserForm As UserForm1
Application.Calculation = xlCalculationManual
path = ThisWorkbook.path & "\*.*"
Filename = Dir(path)
'the problem is here:
'x = user form result***************
'if cancel = true, end sub
Set ws = ThisWorkbook.Sheets("FILES")
i = 0
Do While Filename <> ""
'var = InStr(Filename, ws.Cells(2, 7).Value) 'this is current code, it checks if the cell has open or close
var = InStr(Filename, x)
If var <> 0 Then
i = i + 1
ws.Cells(i + 1, 1) = Filename
Filename = Dir()
Else: Filename = Dir()
End If
Loop
Application.Calculation = xlCalculationAutomatic
ws.Cells(1, 2) = i
MsgBox i & " : files found in folder"
End Sub
And this is my current user form code:
Private Sub Cancel_Click()
Me.Tag = 3 ' EndProcess
Me.Hide
End Sub
Private Sub ClosingType_Click()
Me.Tag = 2 ' "CLOSING"
Me.Hide
End Sub
Private Sub OpeningType_Click()
Me.Tag = 1 ' "OPENING"
Me.Hide
End Sub
Any ideas?
add following code to your CountFiles3() sub in the "'the problem is here:" section:
Dim x As String
x = GetValue
If x = "end" Then Exit Sub
then add following code in any module:
Function GetValue()
With MyUserForm '<--| change "MyUserForm " to your actual UserForm name
.Show
GetValue = .Tag
End With
Unload MyUserForm '<--| change "MyUserForm " to your actual UserForm name
End Function
and change your Userform code as follwos
Private Sub Cancel_Click()
Me.Tag = "end" ' EndProcess
Me.Hide
End Sub
Private Sub ClosingType_Click()
Me.Tag = "close" ' "CLOSING"
Me.Hide
End Sub
Private Sub OpeningType_Click()
Me.Tag = "open" ' "OPENING"
Me.Hide
End Sub
I would like the following code to add values to a combobox, then when the user inputs characters into the combobox, the dropdown feature of the combobox will show only those items which contain those characters, similarly to the way the Google Search Bar works.
(source: intersites.com)
Code Edit:
Option Explicit
Option Compare Text
Public LC As Long
Public Count As Integer
Dim ComboArray() As String
'Initializes the userform, and saves values from database into an array
Private Sub UserForm_Initialize()
LC = Cells(1, Columns.Count).End(xlToLeft).Column
ReDim ComboArray(1 To LC)
For Count = 1 To LC
ComboArray(Count) = Cells(1, Count).Value
Next Count
End Sub
'Prevents changes if the down key is pressed?
Private Sub ComboBox_SiteName_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Application.ScreenUpdating = False
End Sub
'Adds values to combobox if they contain the string input by user
Private Sub ComboBox1_Change()
Dim pos As Integer
Dim i As Integer
ComboBox1.Clear
For Count = 1 To LC
pos = InStr(1, ComboArray(Count), ComboBox1.Value)
If pos <> 0 Then
With ComboBox1
.AddItem Cells(1, Count)
End With
End If
Next Count
End Sub
Here is a simple example, which may need refinement for your purposes, but illustrates the general principles of using the KeyPress event to build a string of user input, and compare that to each item in the list, effectively filtering the list to values that start with the input string.
This needs some refinement to handle backspacing, deleting, etc., which I tried to do, but didn't get as far as I'd like.
Code:
Option Explicit
Dim cbList As Variant
Dim userInput$
'### USERFORM EVENTS
Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 8, 48
'MsgBox "Backspace"
Debug.Print "Backspace"
If userInput <> "" Then
userInput = Left(userInput, Len(userInput) - 1)
End If
Case 46
'MsgBox "Delete"
Debug.Print "Delete"
userInput = Replace(userInput, ComboBox1.SelText, "")
End Select
End Sub
Private Sub UserForm_Activate()
Dim cl As Range
userInput = ""
For Each cl In Range("A1:A8")
Me.ComboBox1.AddItem cl.Value
Next
Me.ComboBox1.MatchRequired = False
cbList = Me.ComboBox1.List
End Sub
Private Sub UserForm_Terminate()
userInput = ""
End Sub
'#### END USERFORM EVENTS
'#### COMBOBOX EVENTS
Private Sub ComboBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Me.ComboBox1.List = cbList
' Capture the user input in module variable
userInput = userInput & Chr(KeyAscii)
Debug.Print "input: " & userInput
Debug.Print KeyAscii
Dim i As Long, itm
For i = Me.ComboBox1.ListCount - 1 To 0 Step -1
itm = Me.ComboBox1.List(i)
If Not StartsWith(CStr(itm), userInput) Then
Me.ComboBox1.RemoveItem i
End If
Next
If Me.ComboBox1.ListCount = 0 Then
Me.ComboBox1.List = cbList
Else
Me.ComboBox1.List = Me.ComboBox1.List
End If
Me.ComboBox1.DropDown
End Sub
'#### END COMBOBOX EVENTS
'#### HELPER FUNCTIONS
Function StartsWith(imtVal$, inputStr$, Optional caseSensitive As Boolean = False)
', Optional caseSensitive As Boolean = False
'If Not caseSensitive Then
imtVal = LCase(imtVal)
inputStr = LCase(inputStr)
'End If
StartsWith = VBA.Strings.Left(imtVal, Len(inputStr)) = inputStr
End Function
'#### END HELPER FUNCTIONS
I have a vlookup userform which autofills the details in the form based on the seat n°.
Now I want to incoroporate a ref edit to paste these data from the text box to the cells the user chooses with the refedit. Hence i would need some help in going about these. This is the code i have used. I potentially want to insert 3 refedit boxes for user to select the cell they want to paste each of the data (Name,Dept and Ext No.) from the textbox.
See my code below:
Option Explicit
Private Sub Frame1_Click()
End Sub
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim answer As Integer
answer = TextBox1.Value
TextBox2.Value = WorksheetFunction.VLookup(answer, Sheets("L12 - Data Sheet").Range("B:E"), 2, False)
TextBox3.Value = WorksheetFunction.VLookup(answer, Sheets("L12 - Data Sheet").Range("B:E"), 3, False)
TextBox4.Value = WorksheetFunction.VLookup(answer, Sheets("L12 - Data Sheet").Range("B:E"), 4, False)
End Sub
Private Sub TextBox2_Change()
End Sub
Private Sub TextBox3_Change()
End Sub
Private Sub TextBox4_Change()
End Sub
Private Sub CancelButton_Click()
Unload Me
End
End Sub
I have tried figuring out a code to solve this issue but I am getting an object required error. My rngcopy would be textbox2.value (Name) and the rngpaste location would be the ref edit 1.
This is the code
Private Sub PasteButton_Click()
Dim rngCopy As Range, rngPaste As Range
Dim wsPaste As Range
Dim answer As Integer
answer = TextBox1.Value
If RefEdit1.Value <> "" Then
TextBox2.Value = WorksheetFunction.VLookup(answer, Sheets("L12 - Data Sheet").Range("B:E"), 2, False)
Set rngCopy = TextBox2.Value
Set wsPaste = ThisWorkbook.Sheets(Replace(Split(TextBox2.Value, "!")(0), "'", ""))
Set rngPaste = wsPaste.Range(Split(TextBox2.Value, "!")(1))
rngCopy.Copy rngPaste
Else
MsgBox "Please select an Output range"
End If
End Sub
You should get the row index with Match and expose it to the form so it can be used by the copy function.
And to set the target pointed by a Ref control, just evalute the .Value property with Range():
Range(RefEdit.Value).cells(1, 1) = Worksheet.Cells(row, column)
The form:
The code:
' constants to define the data
Const SHEET_DATA = "L12 - Data Sheet"
Const COLUMN_SEAT = "B"
Const COLUMNN_NAME = "C"
Const COLUMN_DEPT = "D"
Const COLUMN_EXTNO = "E"
Private Sheet As Worksheet
Private RowIndex As Long
Private Sub TxtSeatNo_Change()
Dim seatno
'clear the fields first
Me.TxtName.value = Empty
Me.TxtDept.value = Empty
Me.TxtExtNo.value = Empty
RowIndex = 0
If Len(TxtSeatNo.value) Then
Set Sheet = ThisWorkbook.Sheets(SHEET_DATA)
On Error Resume Next
' get the seat number to either string or double
seatno = TxtSeatNo.value
seatno = CDbl(seatno)
' get the row index containing the SeatNo
RowIndex = WorksheetFunction.match(seatno, _
Sheet.Columns(COLUMN_SEAT), _
0)
On Error GoTo 0
End If
If RowIndex Then
' copy the values from the sheet to the text boxes
Me.TxtName.value = Sheet.Cells(RowIndex, COLUMNN_NAME)
Me.TxtDept.value = Sheet.Cells(RowIndex, COLUMN_DEPT)
Me.TxtExtNo.value = Sheet.Cells(RowIndex, COLUMN_EXTNO)
End If
End Sub
Private Sub BtCopy_Click()
If RowIndex < 1 Then Exit Sub
' copy the current values to the cells pointed by the ref controls
If Len(Me.RefName.value) Then _
Range(Me.RefName.value) = Sheet.Cells(RowIndex, COLUMNN_NAME)
If Len(Me.RefDept.value) Then _
Range(Me.RefDept.value) = Sheet.Cells(RowIndex, COLUMN_DEPT)
If Len(Me.RefExtNo.value) Then _
Range(Me.RefExtNo.value) = Sheet.Cells(RowIndex, COLUMN_EXTNO)
End Sub
Private Sub BtlClose_Click()
' close the form
Unload Me
End Sub
You are declaring your rngCopy as a Range Object and then later on you are binding it to a .value method of the range object.
Set rngCopy = TextBox2.Value
This is likely where you are encountering errors. Try declaring a string and assigning it to your copy value.
Dim string1 As String
string1 = TextBox2.Value
Step through your code editor with the LOCALS window open, and watch what happens to your rngCopy object when you assign a string to it.
I am unable to call macros whose names I have stored in a String Array.
I attach the code.
Option Explicit
Option Compare Text
Dim i, Ro As Integer
Public Sub Universal_Macro()
Dim Col(10) As Integer
Dim macro_name(10) As String
Ro = ActiveCell.Row
i = 1
For i = 1 To 10
Call Mac_Sched(Col(), macro_name())
Next
End Sub
Sub Mac_Sched(Col() As Integer, Internal_Array() As String)
Cells(Ro, Col(i)).Select
Call Internal_Array(i)
End Sub
Getting error in the sub Mac_Sched.
Try to use Application.Run:
Sub RunMc()
Dim a(1 To 2) As String
Dim MN As String
For i = 1 To 2 'Fill the array
a(i) = "m" & i
Next
MN = "Module1" 'the module name
For i = LBound(a) To UBound(a)
Application.Run MN & "." & a(i)
Next
End Sub
Sub m1()
Debug.Print "m1"
End Sub
Sub m2()
Debug.Print "m2"
End Sub
TBBH, I really don't know what you are trying to accomplish and the heavily redacted code does nothing to show specific methods other than the attempt at calling a macro from a string derived from an array element.
The Application.OnTime method uses a string as the name of the procedure to call.
Option Explicit
Option Compare Text
Dim i As Integer, Ro As Integer
Sub zero()
Debug.Print "zero: " & i
End Sub
Sub first()
Debug.Print "first: " & i
End Sub
Sub second()
Debug.Print "second: " & i
End Sub
Sub third()
Debug.Print "third: " & i
End Sub
Public Sub Universal_Macro()
Dim Col() As Integer
Dim macro_Name As Variant
macro_Name = Array("zero", "first", "second", "third")
ReDim Col(UBound(macro_Name))
For i = LBound(macro_Name) To UBound(macro_Name)
Col(i) = i
Next
Ro = ActiveCell.Row
For i = LBound(macro_Name) To UBound(macro_Name)
Call macro_Sched(Col(i), macro_Name)
Next
End Sub
Sub macro_Sched(c As Integer, internal_Array As Variant)
Cells(Ro, c + 1).Select '<~~Don't rely on Select! You dont' even reference a worksheet here.
Application.OnTime Now, internal_Array(c)
End Sub
If parameters were to be passed to the children sub procedures, then some sort of string replacement might accommodate this but specifics on the child subs are not evident.
See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.