I'm trying to get different multiple check boxes to write to the same cell without overriding previous info.
If CheckBox13.Value = True _
Then
Range("A1").Value = "True 1"
End If
If CheckBox14.Value = True _
Then
Range("A1").Value = Range ("A1").Value + "True 2"
End If
Does that look accurate?
Taking advantage of the controls' default property, you could use something like this:
Range("A1") = ""
If CheckBox1 Then Range("A1") = "True 1"
If CheckBox2 Then Range("A1") = Range("A1") + ", True 2"
If CheckBox3 Then Range("A1") = Range("A1") + ", True 3"
If CheckBox4 Then Range("A1") = Range("A1") + ", True 4"
If (Range("A1") <> "") And (Left(Range("A1"), 1) = ",") Then
Range("A1") = Mid(Range("A1"), 3)
End If
Related
Situation:
I have a userform as shown below:
current solution
when i click OK, the following result is displayed
That means the checkbox values are stored in individual cells.
desired solution
Can I possibly modify my code such that the value is entered in a single cell for example like in the following picture with various combinations of the checkbox result is shown.
My code is as follows:
Private Sub CommandButton1_Click()
If CheckBox1.Value = True Then Worksheets("Sheet1").Cells(10, 2).Value = "Checked" Else Worksheets("Sheet1").Cells(10, 15).Value = ""
If CheckBox3.Value = True Then Worksheets("Sheet1").Cells(10, 3).Value = "Forwarded" Else Worksheets("Sheet1").Cells(10, 14).Value = ""
If CheckBox4.Value = True Then Worksheets("Sheet1").Cells(10, 4).Value = "Notified" Else Worksheets("Sheet1").Cells(10, 16).Value = ""
End Sub
You should be able to build a string in a variable and then populate the cell with it:
Private Sub CommandButton1_Click()
Dim Value as String
If CheckBox1.Value Then Value = "Checked"
If CheckBox3.Value Then Value = Value & IIf(Value = "", "", " / ") & "Forwarded"
If CheckBox4.Value Then Value = Value & IIf(Value = "", "", " / ") & "Notified"
Worksheets("Sheet1").Cells(10, 2).Value = Value
End Sub
Note the use of IIf to determine whether to conditionally add the separator (" / ") when appropriate, rather than trying to trim it off later.
This is the optimal solution that i could find. I look forward for corrections but so far it works according to my needs.
Private Sub CommandButton1_Click()
Dim Value As String
If CheckBox1.Value Then Value = "Checked"
If CheckBox3.Value Then Value = "Forwarded"
If CheckBox1.Value And CheckBox3.Value Then Value = IIf(Value = "", "", "Checked/") & "Forwarded"
If CheckBox4.Value Then Value = "Notified"
If CheckBox3.Value And CheckBox4.Value Then Value = IIf(Value = "", "", "Forwarded/") & "Notified"
If CheckBox1.Value And CheckBox4.Value Then Value = IIf(Value = "", "", "Checked/") & "Notified"
If CheckBox1.Value And CheckBox3.Value And CheckBox4.Value Then Value = IIf(Value = "", "", "Checked/Forwarded") & "Notified"
Worksheets("Sheet1").Cells(10, 2).Value = Value
End Sub
Thank you.
I am creating a yard management system to keep track of parking spots in a lot.
The userform allows the user to click on a spot in the map (this would be the command button) that is open and then click update which will pull up another userform to fill out information about the truck going to that spot.
Once a user fills in the second userform, the spot changes from green to red to show that it is filled. Right now, there is no way to edit data entered for a spot.
For example, I might need to change the truck status from empty to full.
I think the best way to do this would be
if a spot is red (full and has information entered in the userform), then it will automatically pull up the second userform with the data already entered showing, so if something needs to be changed they can just type in the textbox and press update again.
if the spot is empty, it should pull up the first userform asking to update or clear the spot.
I am not sure if this is possible or the most efficient way to accomplish my goal of editing the already entered information, without having to fill out the entire userform again.
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdClear_Click()
ActiveCell.ClearContents
ActiveCell.Interior.Color = vbGreen
Unload Me
End Sub
Private Sub cmdUpdate_Click()
UpdateInfo.Show
Unload Me
End Sub
Private Sub CommandButton1_Click()
UpdateInfo.Show
Unload Me
End Sub
Private Sub UserForm_Initialize()
lblInfo = ActiveCell.Value
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set rngBDock = Range("BX7:CO7")
Set rngBulk = Range("BZ21:CG21")
Set rngTransT = Range("BF17:BY17")
Set rngTransT1 = Range("BG21:BY21")
Set rngTDock = Range("BL7:BW7")
Set rngEDock = Range("CP7:CT7")
Set rngNDock = Range("CU7:DC7")
Set rngFence = Range("CQ13:CV13")
Set rngNSide = Range("CW13:DB13")
Set rngGEO = Range("BG28:DD28")
Set rngNight = Range("CH21:DD21")
Set rngNewT = Range("DK31:DK65")
Set rngNewTl = Range("DI31:DI65")
Set rngOff = Range("BN40:CL40")
Set rngOffl = Range("BN42:CL42")
Set rng = Union(rngBDock, rngBulk, rngTransT, rngTransT1, rngTDock, rngEDock, rngNDock, rngFence, rngNSide, rngGEO, rngNight, rngNewT, rngNewTl, rngOff, rngOffl)
If Not Intersect(Target, rng) Is Nothing Then
CellInfo.Show
'ActiveCell.Value = cellFill
If Not IsEmpty(ActiveCell.Value) Then
Call RealTimeTracker
End If
End If
Private Sub cmdOkUpdate_Click()
Dim i As Integer, j As Integer
For i = 0 To lbxOption.ListCount - 1
If lbxOption.Selected(i) Then j = j + 1
Next i
If j = 0 Then
MsgBox "Please select an option. ", , "Warning"
Unload Me
UpdateInfo.Show
ElseIf j = 1 Then
NoFill = False
End If
strBOL = txtBOL.Value
strID = txtID.Value
details = txtDet.Value
opt = lbxOption.Value
currtime = time()
today = Format(Now(), "MM/DD/YYYY")
emp = TextBox1.Value
With ActiveCell
spot = .Offset(-1, 0)
If Len(spot) = 0 Then
spot = .Offset(1, 0)
Else
spot = spot
End If
End With
If NoFill = True Then
cellFill = ""
ElseIf NoFill = False Then
With Sheet5
.Range("A1").Value = "Time"
.Range("B1").Value = "Date"
.Range("C1").Value = "Location"
.Range("D1").Value = "Category"
.Range("E1").Value = "BOL"
.Range("f1").Value = "Trailer #"
.Range("g1").Value = "Details"
.Range("H1").Value = "EE Name"
.Range("A2").EntireRow.Insert
.Range("A2").Value = currtime
.Range("B2").Value = today
.Range("C2").Value = spot
.Range("D2").Value = opt
.Range("E2").Value = strBOL
.Range("F2").Value = strID
.Range("G2").Value = details
.Range("H2").Value = emp
.Columns("A:H").AutoFit
End With
If Not IsEmpty(opt) Then
cellFill = opt & " " & vbCrLf & "BOL (last 5 digits): " & strBOL & " " & vbCrLf & "Trailer # " & strID & " " & vbCrLf & details & "EE Name" & emp & " " & vbCrLf
ActiveCell.Value = cellFill
Call RealTimeTracker
End If
End If
Unload Me
Sheet1.Activate
End Sub
I'd like a certain cell to show different values depending on the value of other cells. For example, in my worksheet, A1 is "Title of the film", A2 is "Duration" and A3 is "Genre". A4 should show the message "You should introduce..." and the cell that is empty. For example, if I have only completed A2, A4 should show "You should introduce Title of the film and Genre".
I have previously programmed the macro with a Worksheet_Change so that the sheet changes depending on other values.
I have developed this code so far:
Sub Macro1()
If Range("A1") = "Introduce text" And _
Range("A2") <> "Introduce text" And _
Range("A3") <> "Introduce text" Then
Range("A4") = "You should introduce Title of the film"
Else
If Range("A1") <> "Introduce text" And _
Range("A2") = "Introduce text" And _
Range("A3") <> "Introduce text" Then
Range("A4") = "You should introduce Duration"
Else
If Range("A1") = "Introduce text" And _
Range("A2") <> "Introduce text" And _
Range("A3") ="Introduce text" Then
Range("A4") = "You should introduce Title of the film and Genre"
End if
End if
End if
End Sub
However, with the Ifs, I have to make a condition with every possible combination, and this can take such a long time if I introduce more cells to fill.
Is there any other way to develop the code?
You don't need VBA here since you have a set number of cells (3). You can simply use one or more formulae. However, if you really want VBA (perhaps you want to be able to add more cells in the future) then the following code should work
Sub Macro1()
Dim vTitles As Variant
Dim i As Integer
Dim iRows As Integer
Dim sTempSeparator As String
Dim sToIntroduce As String
Dim bEventsEnabled As Boolean
vTitles = Array("Title of the film", "Duration", "Genre")
iRows = UBound(vTitles) + 1
sTempSeparator = ";" ' anything that is not part of the final text
For i = 1 To iRows
If Cells(i, 1) = "" Then
sToIntroduce = Replace(sToIntroduce, sTempSeparator, ",") & sTempSeparator & " " & vTitles(i - 1)
End If
Next i
bEventsEnabled = Application.EnableEvents
If bEventsEnabled Then Application.EnableEvents = False
With Cells(iRows + 1, 1)
If Len(sToIntroduce) <> 0 Then
sToIntroduce = Right$(sToIntroduce, Len(sToIntroduce) - 2)
sToIntroduce = Replace(sToIntroduce, sTempSeparator, " and")
sToIntroduce = "You should introduce " & sToIntroduce
If .Value <> sToIntroduce Then .Value = sToIntroduce
Else
If Len(.Value) <> 0 Then .ClearContents
End If
End With
If bEventsEnabled Then Application.EnableEvents = True
End Sub
I have encountered a few issues with some code in VBA. I am trying to have the changes made to a cells on an excel sheet show up in comments on the cell the change was made to and I wish for these changes to be stored in a list so I can view them all later. I have tried lots of different pieces of code I have found to try and implement it into the code but none have worked.
Any ideas on how to get this to work?
Worksheet
The below code is what I am currently using
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Adding As Boolean, Finding As Boolean, Subtracting As Boolean
Dim f As Range, v
Select Case Target.Address(True, True)
Case "$A$4": Adding = True
Case "$C$4": Subtracting = True
Case "$E$4": Finding = True
Case Else: Exit Sub
End Select
v = Trim(Target.Value)
If Len(v) = 0 Then Exit Sub
Set f = Me.Range("C8").Resize(1000, 1).Find(v, lookat:=xlWhole)
If Adding Then
If f Is Nothing Then
'not found: add as new row
Set f = Me.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
f.Value = v
End If
f.Offset(0, 1).Value = f.Offset(0, 1).Value + 1
doDate f.Offset(0, 2)
Target.Value = ""
ElseIf Subtracting Then
If f Is Nothing Then
MsgBox v & " not found for subtraction!"
Else
f.Offset(0, 1).Value = f.Offset(0, 1).Value - 1
doDate f.Offset(0, 3)
Target.Value = ""
End If
Else 'finding
If Not f Is Nothing Then
f.EntireRow.Select
Target.Value = ""
Else
MsgBox v & " not found."
End If
End If
If Adding Or Subtracting Then Target.Select
End Sub
Sub doDate(c As Range)
With c
.NumberFormat = "m/d/yyyy h:mm AM/PM"
.Value = Now
End With
End Sub
I have implemented a few formulas on the worksheet but don't see any reason why it would matter in this situation since they only track quantity of items with the same unique identifier.
I also tried some code that added comments to the cells as they were changed that worked but always returned the previous cell value as blank. It is not actually added into the current code though.
Option Explicit
Public preValue As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Target.ClearComments
Target.AddComment.Text Text:="Previous Value was " & preValue & Chr(10) & "Revised " & Format(Date, "mm-dd-yyyy") & Chr(10) & "By " & Environ("UserName")
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target = "" Then
preValue = "a blank"
Else: preValue = Target.Value
End If
End Sub
By and large, the code below should do what you want. I marveled at your use of A4 and C4 to express addition and subtraction. As it is, whatever you change in those two cells, apart from clearing them, will result in a quantity of 1 being added or subtracted. I would have expected that a quantity must be entered there which is processed. If the quantity is fixed at 1 the system appears too elaborate.
Anyway, here's the code. I guess you'll be able to modify it to better suit your needs.
Private Sub Worksheet_Change(ByVal Target As Range)
' 038
Dim LookUp As Variant ' subject
Dim Action As Variant ' add = 1, subtract = -1, find = 2
Dim Fnd As Range ' Result of Find method
Dim Txt As String ' comment text
With Target
If (.Row <> 4) Or (.CountLarge > 1) Then Exit Sub
LookUp = Cells(4, "E").Value
On Error Resume Next
Action = Array(0, 1, 0, -1, 0, 2)(.Column)
End With
If Action And (LookUp <> "") Then
' C8 to end of column C
With Range(Cells(8, "C"), Cells(Rows.Count, "C").End(xlUp))
Set Fnd = .Find(LookUp, .Cells(.Cells.Count), xlValues, xlWhole, xlByRows)
End With
End If
If Fnd Is Nothing Then
Select Case Action
Case -1
MsgBox """" & LookUp & """ not found.", vbInformation, "Can't subtract"
Action = -2
Case 2
MsgBox """" & LookUp & """ not found.", vbInformation, "No record"
Action = -2
Case Else
Set Fnd = Cells(Rows.Count, "C").End(xlUp).Offset(1)
Fnd.Value = LookUp
End Select
End If
With Fnd
If Abs(Action) <> 2 Then
With .Offset(0, 1)
If .Comment Is Nothing Then
.AddComment
Else
Txt = Chr(10)
End If
Txt = "Previous Qty = " & .Value & Chr(10) & _
"Revised " & Format(Date, "mm-dd-yyyy") & Chr(10) & _
"by " & Environ("UserName") & Txt
.Comment.Text Txt, 1, False
.Value = Val(.Value) + Action
With .Offset(0, 2)
.NumberFormat = "m/d/yyyy h:mm AM/PM"
.Value = Now
End With
End With
ElseIf Action = 2 Then
.EntireRow.Select
End If
End With
If Action <> 2 Then Target.Select
End Sub
I need to delete columns in a spreadsheet using a loop instead of manually hardcoding those columns in. However all I get is a very unhelpful Next without For error.
Sub test()
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim colNum2 As Integer
colNum2 = 1
For x = 1 To 32
If Range("A1").Value = "Order No." Then
Next colNum
ElseIf Range("B1").Value = "Line No." Then
Next colNum
ElseIf Range("C1").Value = "Order Qty." Then
Next x
ElseIf Range("D1").Value = "PO" Then
Next x
ElseIf Range("E1").Value = "Sched Date" Then
Next x
ElseIf Range("F1").Value = "Sched MFG Line" Then
Next x
ElseIf Range("G1").Value = "Item No." Then
Next x
ElseIf Range("H1").Value = "Item Width" Then
Next x
ElseIf Range("I1").Value = "Item Height" Then
Next x
ElseIf Range("J1").Value = "SL Color" Then
Next x
ElseIf Range("K1").Value = "Frame Option" Then
Next x
End If
'Checks if the cell matches a specific string required by the sorter
'if TRUE should skip through to the next increment of colNum
Columns(colNum2).EntireColumn.Delete
'uses the current number of colNum to delete the current column number
colNum2 = colNum2 + 1
Next x
'increments colNum by one
'Iterates next through the loop
I feel like this would work with say Java or Python so I'm really irritated VBA won't let me do this.
Can someone please explain what is going wrong with this code?
Just use var = var + 1 instead of Next. Next ends the For cycle.
Also you don't need to repeat the variable name on the Next line since it's already in the For line. (For i = 0 To 5 ... Next)
For x = 1 To 32
If Range("A1").Value = "Order No." Then
colNum = colNum +1
ElseIf Range("C1").Value = "Order Qty." Then
x = x + 1
End If
Next
Keep in mind what Scott Cranner said, the Next will also do x=x+1, so if you only want to increment once per cycle, use the Do While cycle instead
x = 1
Do While x <= 32
If Range("A1").Value = "Order No." Then
colNum = colNum +1
ElseIf Range("C1").Value = "Order Qty." Then
x = x + 1
End If
Loop
It seems to me that you want to delete all of the columns that do not match 'a specific string required by the sorter'. In that case, you could loop through all of the columns header labels, deleting the ones that do not match or use a custom left-to-right sort to put all of the non-matching columns to the right and delete then en masse.
Method 1 - Delete non-matching columns
Sub test1()
Dim c As Long, vCOLs As Variant
vCOLs = Array("Order No.", "Line No.", "Order Qty.", "PO", _
"Sched Date", "Sched MFG Line", "Item No.", _
"Item Width", "Item Height", "SL Color", "Frame Option")
With Application
'.ScreenUpdating = False
'.EnableEvents = False
End With
With Worksheets("sheet1")
With .Cells(1, 1).CurrentRegion
'delete from right-to-left or risk missing one
For c = .Columns.Count To 1 Step -1
If IsError(Application.Match(.Cells(1, c).Value2, vCOLs, 0)) Then
.Columns(c).EntireColumn.Delete
End If
Next c
End With
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Method 2 - Custom sort, then offset and delete
Sub test2()
Dim vCOLs As Variant
vCOLs = Array("Order No.", "Line No.", "Order Qty.", "PO", _
"Sched Date", "Sched MFG Line", "Item No.", _
"Item Width", "Item Height", "SL Color", "Frame Option")
With Application
'.ScreenUpdating = False
'.EnableEvents = False
.AddCustomList ListArray:=vCOLs
End With
With Worksheets("sheet1")
With .Cells(1, 1).CurrentRegion
'custom sort to bring the important fields to the left
.Cells.Sort Key1:=.Rows(1), Order1:=xlAscending, _
Orientation:=xlLeftToRight, Header:=xlNo, _
OrderCustom:=Application.GetCustomListNum(vCOLs)
'offset and delete the unwanted columns
With .Offset(0, Application.Match(vCOLs(UBound(vCOLs)), .Rows(1), 0))
.EntireColumn.Delete
End With
End With
End With
With Application
.DeleteCustomList .GetCustomListNum(vCOLs)
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
With either method you are simply listing the columns you want to keep and removing the rest.
There is a twist between .Cells.Sort.SortFields.Add and .Cells.Sort that usually generates some confusion. The .SortFields.Add method uses a CustomOrder:= parameter and the Range.Sort method uses a OrderCustom:= parameter. The two are most definitely NOT the same but often get used interchangeably with disastrous results.
I suspect you are trying to delete columns based on their text values in row 1. This will give you what you want, just put all the text references that you want to delete in the CASE statement.
Option Explicit
Sub DeleteColumns()
Dim colNum As Integer
colNum = 1
Do While Range(alphaCon(colNum) & 1).Value <> ""
Select Case Range(alphaCon(colNum) & 1).Value
Case "ColumnIDontWant", "AnotherColumnIDontWant"
Columns(colNum).EntireColumn.Delete
End Select
colNum = colNum + 1
Loop
End Sub
Public Function alphaCon(aNumber As Integer) As String
' Fixed version 27/10/2011
Dim letterArray As String
Dim iterations As Integer
letterArray = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
If aNumber <= 26 Then
alphaCon = (Mid$(letterArray, aNumber, 1))
Else
If aNumber Mod 26 = 0 Then
iterations = Int(aNumber / 26)
alphaCon = (Mid$(letterArray, iterations - 1, 1)) & (Mid$(letterArray, 26, 1))
Else
'we deliberately round down using 'Int' as anything with decimal places is not a full iteration.
iterations = Int(aNumber / 26)
alphaCon = (Mid$(letterArray, iterations, 1)) & (Mid$(letterArray, (aNumber - (26 * iterations)), 1))
End If
End If
End Function