I have a simple Userform with two textboxes. User is to enter Part Description in one labelled "Panel ID" and the number of rows that description is to be entered in the same column of the spreadsheet (Quantity). By now, I am OK with adding value in empty row, but got stuck at copying the value to other cells. I have code for copying the value in set range, but cannot find anything that works for what I am looking for. Thanks
Apples Oranges List
Private Sub SubmitBtn_Click()
Dim iRow As Long, C As Long
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Data")
iRow = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
C = QTYBox.Value
With sh
.Cells(iRow, 1) = TxtPanel.Value
End With
End Sub
Private Sub UserForm_Initialize()
'Empty Panel ID cell
TxtPanel.Value = ""
'Empty Quantity cell
QTYBox.Value = ""
'Set focus to panel ID cell
TxtPanel.SetFocus
End Sub
This is code for second problem:
crate form
crate spreadsheet
Private Sub SubmitBtn_Click()
Dim i As Long
Dim sh As Worksheet
Dim lRow As Long
Set sh = ThisWorkbook.Sheets("Data")
lRow = sh.Cells(Rows.Count, 1).End(xlUp).Row
With sh
For i = 2 To lRow
'Criteria search
If .Cells(i, 1).Value = PanelTxt.Value Then
If .Cells(i, 2).Value = IDTxt.Value Then
'Enter date in Crated and Crate #
.Cells(i, 5) = [Text(Now(), "DD-MM-YY HH:MM")]
.Cells(i, 6) = CrateTxt.Value
Exit For
End If
End If
Next
End With
End Sub
Related
In sheet 2 of my workbook, I have names of employees, the dates they came into work, the shifts they worked, and absenteeism. In sheet 1 of my code, I have a lookup sheet where I intend for the employee's name to be typed into a cell and to show all the dates and this person worked, along with the shift and absenteeism into the lookup sheet. I've tried a vriaty of things, but this is my current code:
Private Sub worksheet_change(ByVal Target As Range)
Dim Lookup As Worksheet
Dim Data As Worksheet
Dim LastRow As Long
Dim V As Range
Set Lookup = ThisWorkbook.Worksheets("Lookup")
Set Data = ThisWorkbook.Worksheets("Data")
Set V = Lookup.Range("A1:A2")
LastRow = Data.Cells(Rows.Count, "A").End(xlUp).Row
LookupCounter = 2
For i = 2 To LastRow
If Intersect(V, Target) Is Nothing Then
Lookup.Range("B2:C2000").Delete
ElseIf Lookup.Range("A2") = Data.Cells(i, 2) Then
Lookup.Cells(LookupCounter, 2).Value = Data.Cells(i, 1)
Lookup.Range("B2:B2000").NumberFormat = "mm/dd/yyyy"
Lookup.Cells(LookupCounter, 3).Value = Data.Cells(i, 9)
LookupCounter = LookupCounter + 1
End If
Next i
End Sub
My intention is for when a new name is typed, this clears the info from the columns of the lookup page, and inputs the new data for the new name. The second part of my code where I match the names to the dates works, but I am struggling with the clearing function. What can I do to fix it?
Option Explicit
Private Sub worksheet_change(ByVal Target As Range)
Dim Lookup As Worksheet, Data As Worksheet
Dim LastRow As Long, LookupCounter As Long, i As Long
With ThisWorkbook
Set Lookup = .Worksheets("Lookup")
Set Data = .Worksheets("Data")
End With
If Intersect(Lookup.Range("A1:A2"), Target) Is Nothing Then
Exit Sub
Else
' clear sheet
Lookup.Range("B2:C2000").Delete
LastRow = Data.Cells(Rows.Count, "A").End(xlUp).Row
LookupCounter = 2
' get data
For i = 2 To LastRow
If Data.Cells(i, 2) = Lookup.Range("A2") Then
Lookup.Cells(LookupCounter, 2).Value = Data.Cells(i, 1)
Lookup.Cells(LookupCounter, 3).Value = Data.Cells(i, 9)
LookupCounter = LookupCounter + 1
End If
Next
Lookup.Range("B2:B2000").NumberFormat = "mm/dd/yyyy"
End If
End Sub
I'm trying to make a UserForm with comboboxes and textboxes. I have two combobox that are working together. In the first one you choose the right sheet and in the second you choose the right column in the selected sheet.
My problem is that even though my code is working, the second combobox doesn't use the moving information from the first one. It always displays the columns from the first sheet whatever my choice. So how do I get the data from the first one to use it in the second one?
Here's my code:
Private Sub UserForm_Initialize()
Dim I As Long
Me.ComboBox1.Clear
For I = 7 To Sheets.Count
Me.ComboBox1.AddItem Sheets(I).Name
Next
Me.ComboBox1.Value = ActiveSheet.Name
Me.ComboBox2.Clear
Dim j As Integer
Dim puits As String
j = 3
Do While Worksheets(ComboBox1.Text).Cells(1, j).Value <> ""
Me.ComboBox2.AddItem Worksheets(Me.ComboBox1.Text).Cells(1, j).Value
j = j + 3
Loop
End Sub```
EDIT
[USF is to automate the change of the selected cell in this screenshort, same tables on different sheets][1]
[1]: https://i.stack.imgur.com/7bbQG.png
You need to use the Combobox_Change-Event. This Example shows what I mean:
Private Sub ComboBox1_Change()
Dim ws As Worksheet
Dim lCol As Long, i As Long
Set ws = ThisWorkbook.Worksheets(UserForm1.ComboBox1.Value)
lCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
For i = 1 To lCol
UserForm1.ComboBox2.AddItem ws.Cells(1, i).Value
Next
End Sub
Private Sub UserForm_Initialize()
Me.ComboBox1.Clear
Me.ComboBox2.Clear
Dim ws As Worksheet
Dim i As Long
i = 1
For Each ws In ThisWorkbook.Worksheets
Me.ComboBox1.AddItem ws.Name
i = i + 1
Next ws
End Sub
When I select the Sheet, I change the first Combobox, which triggers the Change-Event. And I then populate the second Combobox according to the selected sheet.
EDIT
You could insert a CommandButton and use code like the following:
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim rng As Range
Set ws = ThisWorkbook.Worksheets(UserForm1.ComboBox1.Value)
Set rng = ws.Range(UserForm1.ComboBox2.Value)
rng.Value = "Your Date"
End Sub
I am creating a VBA Excel program where I can copy the cell value to another sheet if its corresponding checkbox is checked. I have 278 "number" entries in one column and an corresponding individual "checkboxes" in one column. But when click the checkbox, the corresponding row text is not displayed.Instead it shows only the first 5 column values. For example, If I select 5 checkboxes randomly, it shows 1,2,3,4,5 numbers are displayed in the "sheet 2" columns.
Sub Button21_Click()
Dim chkbx As CheckBox
Dim i As Integer
a = Worksheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
For Each chkbx In ActiveSheet.CheckBoxes
If chkbx.Value = xlOn Then
Worksheets("sheet1").Cells(i, 1).Copy
Worksheets("sheet2").Activate
b = Worksheets("sheet2").Cells(i, 1).End(xlUp).Row
Worksheets("sheet2").Cells(b + 1, 1).Select
ActiveSheet.Paste
i = i + 1
End If
Next chkbx
Next i
End Sub
This is the code I've used.
Any help would be appreciated.
An Objects Investigation
The Solution
The TopLeftCell Solution, The Solution, is based on the idea of Tim Williams suggested in the comments.
This will be in your sheet code (Sheet1).
Sub Button21_Click()
executeCheckBoxes
End Sub
The rest will be in a standard module (e.g. Module1).
Sub executeCheckBoxes()
Dim src As Worksheet ' Source Worksheet (Object)
Dim tgt As Worksheet ' Target Worksheet (Object)
Dim chkbx As CheckBox ' CheckBox (For Each Control Variable)
Dim srcLR As Long ' Source Last Row
Dim tgtER As Long ' Target Empty Row
Dim i As Long ' Source Row Counter
Set src = ThisWorkbook.Worksheets("Sheet1")
Set tgt = ThisWorkbook.Worksheets("Sheet2")
srcLR = src.Cells(src.Rows.Count, 1).End(xlUp).Row
tgtER = tgt.Cells(tgt.Rows.Count, 1).End(xlUp).Row + 1
For Each chkbx In src.CheckBoxes
If chkbx.Value = xlOn Then
' Cell Version
tgt.Cells(tgtER, 1).Value = _
src.Cells(chkbx.TopLeftCell.Row, 1).Value
' The following 2 ideas are not so good. They are running into trouble
' when adding new checkboxes if not sooner.
' Index Version
' Assuming the index of the checkbox is 1 for row 2, 2 for 3 etc.
' Adjust the "+1" as needed.
' tgt.Cells(tgtER, 1).Value = src.Cells(chkbx.Index + 1, 1).Value
' Name Version
' Assuming the name of the checkbox is "Check Box 1" for row 2,
' "Check Box 2" for 3 etc. Adjust the "+1" as needed.
' tgt.Cells(tgtER, 1).Value = src.Cells(Val(Right(chkbx.Name, _
' Len(chkbx.Name) - Len("Check Box "))) + 1, 1).Value
tgtER = tgtER + 1
Debug.Print chkbx.Name
End If
Next chkbx
End Sub
Extras
The following are codes used to help to create the two inferior solutions.
Sub deleteCB()
deleteCheckBoxes ThisWorkbook.Worksheets("Sheet1")
End Sub
' Deletes all check boxes on a worksheet.
' Note: When you delete all check boxes, the 'counter' is not reset i.e. if you
' e.g. had "Check Box 100" the next check box will be named "Check Box 101".
' But after you save and close the workbook and open it again,
' the first check box name will be "Check Box 1".
Sub deleteCheckBoxes(Sheet As Worksheet)
Sheet.CheckBoxes.Delete
End Sub
' Creates check boxes in a range.
Sub addCheckBoxes()
Const SheetName As String = "Sheet1"
Const chkRange As String = "B2:B279"
Const chkCaption As String = "Chk"
Dim chk As CheckBox, rng As Range, cel As Range, i As Long
i = 1
With ThisWorkbook.Worksheets(SheetName)
Set rng = .Range(chkRange)
For Each cel In rng.Cells
Set chk = .CheckBoxes.Add(cel.Left, cel.Top, cel.Width, cel.Height)
With chk
.Caption = chkCaption & i
End With
i = i + 1
Next
End With
End Sub
Sub showSomeCheckBoxProperties()
Dim chk As CheckBox, rng As Range, cel As Range, i As Long
i = 1
With ThisWorkbook.Worksheets("Sheet1")
For Each chk In .CheckBoxes
With chk
Debug.Print .BottomRightCell.Address, .Caption, _
.Characters.Count, .Enabled, .Index, .Name, .Placement, _
.Text, .TopLeftCell.Address, .Value, .Visible
End With
Next
End With
End Sub
Extras 2
The following is the code based on the YouTube video
Add Button to Worksheet and Assign a Macro to it -Excel Help by XLorate that helped quite a lot in answering this question.
Sub addButtons()
Dim btn As Button, rng As Range, cel As Range, i As Long
i = 1
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .Range("A1:A3")
For Each cel In rng.Cells
Set btn = .Buttons.Add(cel.Left, cel.Top, cel.Width, cel.Height)
With btn
.Caption = "Macro" & i
.OnAction = "Macro" & i
End With
i = i + 1
Next
End With
End Sub
The following are some other more or less helpful codes which I created while investigating objects.
Sub showSomeShapesProperties()
Dim ws As Worksheet, sh As Shape
Set ws = ThisWorkbook.Worksheets("Sheet1")
For Each sh In ws.Shapes
With sh
If sh.Type = 12 Then
Debug.Print .Name, .Type, .ID, .OnAction, .TopLeftCell.Address
End If
If sh.Type = 8 Then
Debug.Print .Name, .Type, .ID, .OnAction, .TopLeftCell.Address
End If
End With
Next
End Sub
Sub showSomeOleObjectProperties()
Dim ws As Worksheet, oo As OLEObject
Set ws = ThisWorkbook.Worksheets("Sheet1")
For Each oo In ws.OLEObjects
With oo
Debug.Print .Name, .OLEType, .AutoLoad, .Enabled, .Index, _
.BottomRightCell.Address
End With
Next
End Sub
Sub addOLECheckBoxes()
Const srcName As String = "Sheet1"
Dim chk As OLEObject, rng As Range, cel As Range, i As Long
With ThisWorkbook.Worksheets(srcName)
Set rng = .Range("A1:A10")
i = 1
For Each cel In rng.Cells
Set chk = .OLEObjects.Add(ClassType:="Forms.CheckBox.1", _
Left:=cel.Left, Top:=cel.Top, Width:=cel.Width, Height:=cel.Height)
With chk
'.Name = "Chk" & i
'.Placement = xlMoveAndSize
End With
i = i + 1
Next cel
End With
End Sub
I made a calendar sheet in Excel with all 366 days of the year listed in column A
how can I write an Auto_open macro which automatically selects and activates the cell holding the current date?
Give this a try:
Private Sub Workbook_Open()
Dim cell As Range
Sheets("Sheet1").Activate
Set cell = Range("A:A").Find(What:=Date, After:=Range("A1"))
cell.Select
End Sub
I'd write it as:
Private Sub Workbook_Open()
Dim CellToCheck As Range
For Each CellToCheck In Sheet1.Range("A1:A366") 'To make dynamic, you could make use of finding lastrow and searching until that row.
If CellToCheck.Value = Date Then
CellToCheck.Select
Exit For
End If
Next CellToCheck
End Sub
Outcome:
For this code to work you need to enter it into the ThisWorkbook code module and choose Workbook and Open from the appropriate drop-down menus, like so:
Private Sub Workbook_Open()
Dim lastrow As Long
Dim lastcol As Long
Dim t As Date
Dim u As Date
Dim v As Long
Dim w As Long
Dim notolet As String
Sheets("all").Activate ' your sheet name here
With ActiveSheet
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
End With
t = Now()
u = Format(t, "dd/mm/yyyy")
notolet = Split(Cells(1, lastcol).Address, "$")(1)
For v = lastrow To 2 Step -1
Select Case Cells(v, 1).Value
Case u
Range("A" & v & ":" & notolet & v).Interior.ColorIndex = 6
Exit For
End Select
Next
w = v
End Sub
My workbook has two sheets: one "Data" and one "Kiert". I solved to copy rows by specific attributes from "data" to "Kiert" with UserForm, but I added ti user form four textboxes (TextBox1, TextBox2 etc.) and I want to fill the database with constant values added in textbox with one command button in blank colums after pasted data.
I have additional textbox5, which indicates if the copy was succefull ("SIKERES"), this part works fine...
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim Drng As Range, c As Range
Dim i As Long
Dim lastRow As Long
Dim srcRange As Range, fillRange As Range
Set a = TextBox5
Set d = TextBox1
Set ws = Sheets("Data")
Set Drng = ws.Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
For Each c In Drng.Cells
If c = ListBox1 Then
c.EntireRow.Copy
Sheets("Kiert").Range("A1000000").End(xlUp).Offset(1, 0)
Range("F:F" & lastRow).Formula = TextBox1.Value
If c.Value = ListBox1.Value Then
a.Value = "SIKERES"
End If
End If
Next c
End Sub
I insert here an example:
My main problem is I cannot describe a correct range and description of textboxes, and I don't know where I can put it in my code to run it properly.
I tried this:
For Each c In Drng.Cells
If c = ListBox1 Then
c.EntireRow.Copy Sheets("Summary").Range("A1048576").End(xlUp).Offset(1, 0)
Sheets("Kiert").Range("A:A" & lasrRow).Value = TextBox1.Text
If c.Value = ListBox1.Value Then
A.Value = "SIKERES"
End If
End If
Next c
...but its out of range.
It's not very clear what you are trying to do, but the code below will help you paste the values of your textboxes to the relevant column:
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim Drng As Range, c As Range
Dim i As Long
Dim NextFreeRow As Long
Dim srcRange As Range, fillRange As Range
Set Drng = Sheets("Data").Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
For Each c In Drng.Cells 'loop through Column A on Sheet Data
If c = ListBox1.Value Then 'If the cells in Column A Sheet Data matches the selection on your Listbox1 then
NextFreeRow = Sheets("Kiert").Cells(Rows.Count, "A").End(xlUp).Row + 1 'Check the next free row on Sheet Kiert
c.EntireRow.Copy Desination:=Sheets("Kiert").Range("A" & NextFreeRow) 'Paste the entire row from Sheet Data to Sheet Kiert
Range("F" & NextFreeRow).Value = TextBox1.Text 'Copy the contents of TextBox1 to column F
'Add more lines like the one above to copy the values from your Textboxes to the relevant column
TextBox5.Text = "SIKERES"
End If
Next c
End Sub