I want to trigger a macro when I change multiple cells with CTRL+ENTER for each cell separately.
The code sometimes skips rows. What could be causing this some cells scattered within the range?
ChangeCell = Target.Address(0, 0)
' In case of multiple changed cells, RowChangeCell provides the 1st row of the changed range
RowChangeCell = Range(ChangeCell).Row
Range(ChangeCell).Select
With Selection
ChangeStart = .Cells(1, 1).Address
ChangeEnd = .Cells(.Rows.Count, .Columns.Count).Address
ChangeStartRow = Range(ChangeStart).Row
ChangeEndRow = Range(ChangeEnd).Row
End With
Application.ScreenUpdating = False
'If Not Intersection Is Nothing Then
'ChangeCell = Target.Address(0, 0)
'ActiveRowMain = Range(ChangeCell).Row
For ActiveRowMain = ChangeStartRow To ChangeEndRow Step 1
'If ActiveRowMain = 51055 Then
'
' Chck = Worksheets("Main_Report").Range("A" & ActiveRowMain).Value
' MsgBox "Status = " & Chck
'
'End If
'Chck = Worksheets("Main_Report").Range("A" & ActiveRowMain).Value
'MsgBox "MainLine = " & ActiveRowMain & " Status = " & Chck & " ChangeStartRow = " & ChangeStartRow & " ChangeEndRow = " & ChangeEndRow
Call Events_Update_Main_Caller(ActiveRowMain)
Next ActiveRowMain
'MsgBox "Updates are completed"
'End If
Application.ScreenUpdating = True
End Sub
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'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
Background:
I am trying to use access to automatically make quotation, but if use the built-in to convert to pdf. It's not what I want. So I am writing some vba in access to write to excel. In my vba, I open a template excel called "clean.xlsx" to write data from access to it.
The screenshot is the table as part of the quotation template inside the excel
Q1:However, sometimes my data may be too much for a single cell and part of it will be hidden. And I want it to go to next line to be fully displayed instead of being hidden.
The screenshot is the hidden data
Q2:Another thing is if I have too many items. The rows of the table is not automatically extended even though I double checked the setting of AutoCorrect Options in the excel. It just doesn't work. What shall I do?
The following is my code:
'''
Option Compare Database
Private Sub Command31_Click()
On Error GoTo SubError
'******************************************************
' Updated Commits
'******************************************************
'1.Quotation no. 10 Error fixed
'2.positions added
'3.Excel is kept open now
'4.Order of items is now same as the natural input order
'5.Weights now have two digits of decimals
'6."kg" is added after weights
'7.Subtotal added
'declare vars
Dim appExcel As Excel.Application
Dim myWorkbook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim SQL As String
Dim rsl As DAO.Recordset
Dim i, position As Integer
Dim Message, Title, Default, MyValue
'user input for the quotation no.
Message = "Plz Enter Quotation No.:" ' Set prompt.
Title = "InputBox Demo" ' Set title.
Default = "1" ' Set default.
' Display message, title, and default value.
MyValue = InputBox(Message, Title, Default)
'Show user work is being performed
DoCmd.Hourglass (True)
'******************************************************
' RETRIEVE DATA
'******************************************************
'SQL statement to retrieve Article_No from Quotation_Detail table
'SQL = "SELECT Article_No AS [Article No]" & _
'"FROM Quotation_Detail " & _
'"ORDER BY Article_No "
'SQL statement to retrieve Company(0), Person(1), Telefone(2), Email(3), Address(4), City(5), Postcode(6),
'Province(7), USCI Num(8), Short Name(9) from Customers Table and Buyer(10), Quotation No(11),Quotation
'Date(12), Revision(13), Article_No(14), Quantity(15), Matchcode(16), RMB_price(17),reference(18) from Quotation Query 1,
'Description(19) & Weight(20) from Spare_Parts Table.
SQL = "SELECT Customers.Company, Customers.Person, Customers.Telefone, Customers.[E-Mail], " & _
"Customers.Address, Customers.City, Customers.Postcode, Customers.Province, Customers.[USCI Num], " & _
"Customers.[Short Name], [Quotation Query1].Buyer, [Quotation Query1].[Quotation No], " & _
"[Quotation Query1].[Quotation Date], [Quotation Query1].Revision, " & _
"[Quotation Query1].Article_No, [Quotation Query1].Quantity, [Quotation Query1].Matchcode, " & _
"[Quotation Query1].RMB_price,[Quotation Query1].[Our Reference], Spare_Parts.Description, Spare_Parts.[Weight (kg)] " & _
"FROM Spare_Parts INNER JOIN (Customers INNER JOIN [Quotation Query1] ON Customers.[Short Name] = [Quotation Query1].[Buyer]) ON Spare_Parts.[Article_No] = [Quotation Query1].[Article_No] " & _
"WHERE CStr([Quotation Query1].[Quotation No]) = '" & MyValue & "' "
'To select only one quotation with the quotation no. to make the quotation
'Quotation No. is an auto no.,the index shall be used instead of what seems like
' '"& is fixed format for text
'Execute query and populate recordset
Set rsl = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)
'If no data, don't bother opening Excel, just quit
If rsl.RecordCount = 0 Then
MsgBox "No data selected for export", vbInformation + vbOKOnly, "No data exported"
GoTo SubExit
End If
'Loop each row to print data in rsl(0) to test what's in the rsl
'rsl(0) is the short name
'rsl(1) is the company name
' Contrl G to see what have been printed
' After this, the cursoe will at the end and filuence accessing values of fields in the next step
' Thus, this should be commented out
'Do While Not rsl.EOF
' Debug.Print rsl(5)
' rsl.MoveNext
'Loop
Set appExcel = CreateObject("Excel.Application")
Set myWorkbook = appExcel.Workbooks.Open("C:\Users\Cindy\Desktop\clean.xlsx")
appExcel.Visible = True
Set xlSheet = myWorkbook.Worksheets(1)
With xlSheet
.Name = "Quotation"
.Cells.Font.Name = "Calibri"
.Cells.Font.Size = 11
'build quotation info
'Quotation No. in C16
If rsl.Fields(11).Value < 10 Then
.Range("C16").Value = "SHA-002-000" + CStr(rsl.Fields(11).Value)
ElseIf rsl.Fields(11).Value < 100 Then
.Range("C16").Value = "SHA-002-00" + CStr(rsl.Fields(11).Value)
ElseIf rsl.Fields(11).Value < 1000 Then
.Range("C16").Value = "SHA-002-0" + CStr(rsl.Fields(11).Value)
ElseIf rsl.Fields(11).Value < 10000 Then
.Range("C16").Value = "SHA-002-" + CStr(rsl.Fields(11).Value)
Else
GoTo SubExit
End If
'Company name in A6
.Range("A6").Value = Nz(rsl.Fields(0).Value, "")
'Contact Person name in A7
.Range("A7").Value = Nz(rsl.Fields(1).Value, "")
'Fowarding address in A8
.Range("A8").Value = Nz(rsl.Fields(4).Value, "")
'Postcode in A9
.Range("A9").Value = Nz(rsl.Fields(6).Value, "")
' City in C9
.Range("C9").Value = Nz(rsl.Fields(5).Value, "")
' If there's province
If rsl.Fields(5).Value <> rsl.Fields(7).Value Then
' Province in F9
.Range("F9").Value = Nz(rsl.Fields(7).Value, "")
.Range("H9").Value = "Province"
End If
'Telephone in B12
.Range("B12").Value = Nz(rsl.Fields(2).Value, "")
' Email in C13
.Range("C13").Value = Nz(rsl.Fields(3).Value, "")
' USCI in B14
.Range("B14").Value = Nz(rsl.Fields(8).Value, "")
'Revision in F16
.Range("F16").Value = Nz(rsl.Fields(13).Value, "")
' Date in B17
.Range("B17").Value = Nz(rsl.Fields(12).Value, "")
' Reference in C18
If rsl.Fields(18).Value = 1 Then
.Range("C18").Value = "DD"
ElseIf rsl.Fields(18).Value = 2 Then
.Range("C18").Value = "WY"
End If
'Put the name of the feilds in rsl to Cell(1,cols + 1)
'For cols = 0 To rsl.Fields.Count - 1
' .Cells(1, cols + 1).Value = rsl.Fields(cols).Name
'Next
'Copy data from recordset to sheet
'.Range("A2").CopyFromRecordset rsl
'provide initial value to row counter
i = 25
'provide initial value to row posiiton counter
position = 1
'Loop through recordset and copy data from recordset to sheet
Do While Not rsl.EOF
'Item No. are written staring from B25 to the end
.Range("B" & i).Value = Nz(rsl.Fields(14).Value, "")
'Quantitities are written staring from C25 to the end
.Range("C" & i).Value = Nz(rsl.Fields(15).Value, "")
'Unit prices are written starting from I25 to the end
.Range("I" & i).Value = Nz(rsl.Fields(17).Value, "")
'Matcth codes are written starting from D25 to the end
.Range("D" & i).Value = Nz(rsl.Fields(16).Value, "")
'Despcriptions are written starting from E25 to the end
.Range("E" & i).Value = Nz(rsl.Fields(19).Value, "")
'Weights are written starting from H25 to the end
' .Range("H" & i).Value = Format(Nz(rsl.Fields(20).Value, ""), "#,##0.00")
'To add kg after weight
'Have issue: error number:94= invalid use of null even empty checked
If Not IsNull(rsl.Fields(20).Value) Then
.Range("H" & i).Value = CStr(Format(rsl.Fields(20).Value, "#,##0.00")) + "kg"
End If
'Positions are written starting from A25 to the end
.Range("A" & i).Value = Nz(position, "")
'Subtotals are written starting from J25 to the end
.Range("J" & i).Value = rsl.Fields(15).Value * rsl.Fields(17).Value
i = i + 1
position = position + 1
rsl.MoveNext
Loop
End With
'Save as excel file using the input MyValue and clean appExcel
myWorkbook.SaveAs FileName:="C:\Users\Cindy\Desktop\" & MyValue & ".xlsx"
Set appExcel = Nothing
SubExit:
On Error Resume Next
DoCmd.Hourglass False
appExcel.Visible = True
rsl.Close
Set rsl = Nothing
Exit Sub
SubError:
MsgBox "Error Number:" & Err.Number & "= " & Err.Description, vbCritical + vbOKOnly, "An Error occured"
GoTo SubExit
End Sub
'''