Multiple Checkbox transfer in 1 Row without overlapping - vba

I'm currently creating a reporting tool I have a problem with regards in exporting the details from User form to my Database (Sheet1).
Scenario:
What if the user checked multiple checkboxes in the user form, how will it transfer the data from multiple checkboxes to 1 row "G2" without overlapping? I'm using a command button to transfer the data to the empty cell
Sample UserForm:
# Mike
Sample WorkSheet of Userform

Something that might work then is this:
Private Sub CommandButton4_Click()
RowCount = Worksheets("Sheet1").Range("A1").CurrentRegion.Rows.count
With Worksheets("Sheet1").Range("A1")
If CheckBox1.Value = True Then
.Offset(RowCount, 6).Value = .Offset(RowCount, 6).Value & vbCrLf & "Unable to remove footer"
Else:
.Offset(RowCount, 6).Value = ""
End If
If CheckBox2.Value = True Then
.Offset(RowCount, 6).Value = .Offset(RowCount, 6).Value & vbCrLf & "Unable to use PMSectionHead as First Level header/section"
Else:
.Offset(RowCount, 6).Value = ""
End If
End With
End Sub
I have it adding to the value that is already in the cell and putting a newline before each new value that is added. Then you will probably have to add an If for each checkbox since you are manually adding a string.
You need to check each one to see if more than one checkbox is checked. If you have them in an If ... ElseIf statement it will stop after the first true statement and not check all the rest.
EDIT
Private Sub CommandButton4_Click()
Dim RowCounter
RowCounter = 0
RowCount = Worksheets("Sheet1").Range("A1").CurrentRegion.Rows.count
With Worksheets("Sheet1").Range("A1")
If CheckBox1.Value = True Then
.Offset(RowCount + RowCounter, 6).Value = .Offset(RowCount + RowCounter, 6).Value & vbCrLf & "Unable to remove footer"
RowCounter = RowCounter + 1
Else:
.Offset(RowCount, 6).Value = ""
End If
If CheckBox2.Value = True Then
.Offset(RowCount + RowCounter, 6).Value = .Offset(RowCount + RowCounter, 6).Value & vbCrLf & "Unable to use PMSectionHead as First Level header/section"
RowCounter = RowCounter + 1
Else:
.Offset(RowCount, 6).Value = ""
End If
End With
End Sub
I added a counter to the sub that will count if any of the checkboxes have been checked and go that many rows down starting with 0 rows down for 1 box checked. Not entirely sure that is what you were looking for, but I think it will work for you.

Related

Add data in specific rows in vba

After I click the command button, I want my excel to do:
Input what I type in text boxes / select in combo boxes in specific columns without deleting the one I previously entered
But at this moment, it does not work as I expected or enter any of input from text boxes and combo boxes.
The script I wrote is:
Private Sub
If TextBox1.Value = "" Or TextBox2.Value = "" Or TextBox3.Value = "" Then
If MsgBox ("There might one or more empty cells,
do you want to continue to proceed?", vbQuestion + vbYesNo) <> vbYes Then
Exit Sub
End If
End If
Dim invsheet As Worksheet
Dim pacsheet As Worksheet
Set invsheet = ThisWorkbook.Sheets("INV")
Set pacsheet = ThisWorkbook.Sheets("PAC")
invsheet.Range("A1").Value = TextBox6.Text
invsheet.Range("I5").Value = TextBox7.Text
invsheet.Range("A21").Value = TextBox5.Text
invsheet.Range("A25").Value = ComboBox1.Value
inv_nr = invsheet.Cells(Row.Count, 1).End(xlUp).Row +1
invsheet.Cells(inv_nr, 5).Value = Me.TextBox1
invsheet.Cells(inv_nr, 4).Value = Me.ComboBox2
pac_nr = pacsheet.Cells(Row.Count, 1).End(xlUp).Row +1
pacsheet.Cells(pac_nr, 5).Value = Me.TextBox2
pacsheet.Cells(pac_nr, 5).Value = Me.TextBox3
pacsheet.Cells(pac_nr, 5).Value = Me.TextBox4
Problem:
inv_nr = invsheet.Cells(Row.Count, 1).End(xlUp).Row +1
invsheet.Cells(inv_nr, 5).Value = Me.TextBox1
invsheet.Cells(inv_nr, 4).Value = Me.ComboBox2
pac_nr = pacsheet.Cells(Row.Count, 1).End(xlUp).Row +1
pacsheet.Cells(pac_nr, 5).Value = Me.TextBox2
pacsheet.Cells(pac_nr, 7).Value = Me.TextBox3 'mistyped it. supposed to be 7
pacsheet.Cells(pac_nr, 9).Value = Me.TextBox4 'mistyped it. supposed to be 9
This block of code does not work and create any output on the worksheet.
I will really appreciate your help.
Thank you!
You're not placing anything in column A (except A1, A21, and A25 of invsheet), so it's not a good idea to set your inv_nr and pac_nr variables based on the last used cell in column A.
Try basing it on one of the columns you are populating with data, e.g. column 5:
'Always qualify "Rows" (and don't mistype it as "Row")
inv_nr = invsheet.Cells(invsheet.Rows.Count, 5).End(xlUp).Row + 1
invsheet.Cells(inv_nr, 5).Value = Me.TextBox1
invsheet.Cells(inv_nr, 4).Value = Me.ComboBox2
'Always qualify "Rows" (and don't mistype it as "Row")
pac_nr = pacsheet.Cells(pacsheet.Rows.Count, 5).End(xlUp).Row + 1
pacsheet.Cells(pac_nr, 5).Value = Me.TextBox2 'Note: This is pointless because the next line overwrites it
pacsheet.Cells(pac_nr, 5).Value = Me.TextBox3 'Note: This is pointless because the next line overwrites it
pacsheet.Cells(pac_nr, 5).Value = Me.TextBox4

Input box value insert in the next empty cell in row to the right

I am trying to add to the next empty cells to the right, the data from the user form text box, if data already exists. Meaning if "E1" is has date, add to "F1" and so on, but only is the range "E1:S1".
Here is a screenshot of the report:
And here is what I've got so far (but it stops as E1):
Private Sub CommandButton1_Click()
If Range("E1") = "" Then Range("E1") = UserForm2.TextBox1.Value Else
Range("E1").End(xlToRight) = UserForm2.TextBox1.Value
If Range("E2") = "" Then Range("E2") = UserForm2.TextBox2.Value Else
Range("E2").End(xlToRight) = UserForm2.TextBox2.Value
End Sub
The End(xlToRight is only going to the end of the populated cells not the next open one. You need to move one more column over after finding the last populated cell. Use Cells() and I prefere staring at the furthest column and coming back.
Private Sub CommandButton1_Click()
If Range("E1").Value = "" Then Range("E1").Value = UserForm2.TextBox1.Value Else
Cells(1, Cells(1, Columns.Count).End(xlToLeft).Column + 1).Value = UserForm2.TextBox1.Value
If Range("E2").Value = "" Then Range("E2").Value = UserForm2.TextBox2.Value Else
Cells(2, Cells(2, Columns.Count).End(xlToLeft).Column + 1).Value = UserForm2.TextBox2.Value
End Sub

negative Flexi time logging using a userform

I'm still a Noob when it comes to VBA, but I'm gradually picking it up as I go along. I need help trying to get my simple Flexitime input form to log flexi time "taken" as negative time (-01:00) on a spreadsheet, but I'm not sure how to go about doing it.
This is what I've got so far:
Private Sub submit_Click()
Dim wb As Workbook
Dim ws As Worksheet
Dim irow As Long
Set wb = FlexBook
Set ws = FlexBook.Worksheets("Flex Data")
irow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
If Trim(Me.employee.Value) = "" Then
Me.employee.SetFocus
MsgBox "Please select a name"
Exit Sub
End If
If Trim(Me.owta.Value) = "" Then
Me.owta.SetFocus
MsgBox "Please select whether it is time taken or time owed"
Exit Sub
End If
If Trim(Me.Time.Value) = "" Then
Me.Time.SetFocus
MsgBox "Please input the amount of time"
Exit Sub
End If
If Trim(Me.dateflex.Value) = "" Then
Me.dateflex.SetFocus
MsgBox "Please input the date the flex was owed or taken"
Exit Sub
End If
If Trim(Me.author.Value) = "" Then
Me.author.SetFocus
MsgBox "Please confirm who has authorised this"
Exit Sub
End If
If Trim(Me.owta.Value) = "Owed" Then
Time = Time
ElseIf Trim(Me.owta.Value) = "Taken" Then
Time = Time * -1
Exit Sub
End If
'Insert data in to the table
ws.Cells(irow, 1).Value = Me.employee.Value
ws.Cells(irow, 2).Value = Me.owta.Value
'ws.Cells(irow, 3).Value = ? <---cell to indicate positive or negative time
ws.Cells(irow, 4).Value = CDate(Me.dateflex.Value)
ws.Cells(irow, 5).Value = Me.author.Value
'clear the data
Me.employee.Value = ""
Me.owta.Value = ""
Me.Time.Value = ""
Me.dateflex.Value = ""
Me.author.Value = ""
Me.employee.SetFocus
End Sub
You could use an instant If, an If block, or a Select Case - your choice:
ws.Cells(irow, 3).Value = IIf(Trim(Me.owta.Value) = "Owed", "+", "-")
'// However I wouldn't advise this if you want to evaluate "Owed" and "Taken" seperately.
or
If Trim(Me.owta.Value) = "Owed" Then
ws.Cells(irow, 3).Value = "+"
ElseIf Trim(Me.owta.Value) = "Taken" Then
ws.Cells(irow, 3).Value = "-"
End If
or
Select Case Trim(Me.owta.Value)
Case "Owed": ws.Cells(irow, 3).Value = "+"
Case "Taken": ws.Cells(irow, 3).Value = "-"
End Select
All have their own pros and cons, but in the context in which you are using them will show little difference.

How to check for different worksheet names in excel and add new in case it doesn't exist

I'm exporting my data from MS Project to MS Excel (single pre-defined file with a given name all the time, for e.g. XYZ.xlsx) and want to have different worksheet in the excel for every workstream in the project. And number of workstreams can increase in future, thus I've to keep it dynamic.
As of now my code does the export, but I also want it to check if the workstream already exists,
- if yes, delete all the data in that worksheet and paste the new data in XYZ file.
- if no, create a new worksheet in the XYZ file and paste the data into it.
Can anyone please help as I'm on a deadline to finish it.
Code that I'm using it,
Set tsks = ThisProject.Tasks
For Each t In tsks
If Not t Is Nothing Then
If t.OutlineLevel > 1 Then
If t.OutlineLevel = 2 Then
If ExcelRowCounter > 2 Then
'Finish formatting the sheet we just finished
For i = 1 To 7
xlSheet.Columns(i).AutoFit
Next i
End If
'Add Excel sheet, name it and define column headers
AppActivate ExcelAppTitle
Set xlSheet = xlBook.Worksheets.Add
ExcelSheetName = Left(Replace(t.Name, "&", "and"), 30)
xlSheet.Name = ExcelSheetName
xlSheet.Cells(1, 1).Value = "Task Name"
xlSheet.Cells(1, 2).Value = "Duration (days)"
xlSheet.Cells(1, 3).Value = "Start Date"
xlSheet.Cells(1, 4).Value = "Finish Date"
xlSheet.Cells(1, 5).Value = "Workstream Group"
xlSheet.Cells(1, 6).Value = "% Complete"
xlSheet.Cells(1, 7).Value = "Status"
xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, 7)).Font.Bold = True
ExcelRowCounter = 2
End If
xlSheet.Cells(ExcelRowCounter, 1).Value = t.Name
xlSheet.Cells(ExcelRowCounter, 2).Value = t.Duration / (8 * 60)
xlSheet.Cells(ExcelRowCounter, 3).Value = Format(t.Start, "mm/dd/yyyy")
xlSheet.Cells(ExcelRowCounter, 4).Value = Format(t.Finish, "mm/dd/yyyy")
xlSheet.Cells(ExcelRowCounter, 5).Value = t.Text1
xlSheet.Cells(ExcelRowCounter, 6).Value = t.PercentComplete
xlSheet.Cells(ExcelRowCounter, 7).Value = t.Number1
xlSheet.Cells(ExcelRowCounter, 1).IndentLevel = 2 * (t.OutlineLevel - 2)
If t.Summary = "True" Then
xlSheet.Range(xlSheet.Cells(ExcelRowCounter, 1), xlSheet.Cells(ExcelRowCounter, 6)).Font.Bold = True
End If
ExcelRowCounter = ExcelRowCounter + 1
End If
End If
Next t
For i = 1 To 7
xlSheet.Columns(i).AutoFit
Next i
Here's as simple method:
Function AddOrGetWorksheet(withName As String) As Worksheet
Dim found As Boolean
found = False
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
If (LCase(ws.Name) = LCase(withName)) Then
found = True
Set AddOrGetWorksheet = ws
Exit For
End If
Next
If (Not found) Then
Set AddOrGetWorksheet = ActiveWorkbook.Sheets.Add()
AddOrGetWorksheet.Name = withName
End If
End Function

Excel VBA UserForm, Need to create new ID every time form is called and save it on Add/Save button click

I have created a simple UserForm to enter new customer details to the Customer List in the spreadsheet, form works fine except for one little thing, which is New Customer ID.
Basically what I need this for to do is once form is opened/called new customer ID need to be created, which could be and Alfa numerical set of characters like AA-01234, AA-01235, AA-01236 and so on.
Also, is there a way of posting newly added Customer ID in the MsgBox along with MsgBox "One record added to Customers List. New Customer ID is "
All of my attempts to create this are failing and causing errors, which I really cannot figure out since I am new to VBA and had never used it until now.
Please help me a little.
Here is my code, Customer ID is TextBox1.
Thanks in advance
Private Sub UserForm_Activate()
Dim iRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Customers")
RefNo.Enabled = True
'find last data row from database
iRow = ws.Cells(Rows.Count, 8).End(xlUp).Row
If ws.Range("A" & iRow).Value = "" Then
RefNo.Text = "TAS1"
ws.Range("A" & iRow).Value = RefNo
Else
RefNo.Text = "TAS" & Val(Mid(ws.Cells(iRow, 1).Value, 4)) + 1
ws.Range("A" & iRow + 1).Value = RefNo
End If
TextBox1.Value = WorksheetFunction.Max(Range("Customers!A8:A65536")) + 1
End Sub
Private Sub Addreccord_Click()
Dim LastRow As Object
Set LastRow = Range("Customers!A65536").End(xlUp)
LastRow.Offset(1, 0).Value = WorksheetFunction.Max(Range("Customers!A8:A65536")) + 1
LastRow.Offset(1, 1).Value = TextBox2.Text
LastRow.Offset(1, 2).Value = TextBox3.Text
LastRow.Offset(1, 3).Value = TextBox4.Text
LastRow.Offset(1, 4).Value = TextBox5.Text
LastRow.Offset(1, 5).Value = TextBox6.Text
LastRow.Offset(1, 6).Value = TextBox7.Text
LastRow.Offset(1, 7).Value = TextBox8.Text
LastRow.Offset(1, 8).Value = TextBox9.Text
LastRow.Offset(1, 9).Value = TextBox10.Text
LastRow.Offset(1, 10).Value = TextBox11.Text
MsgBox "One record added to Customers List"
response = MsgBox("Do you want to enter another record?", _
vbYesNo)
If response = vbYes Then
TextBox1.Value = WorksheetFunction.Max(Range("Customers!A8:A65536")) + 1
TextBox2.Text = ""
TextBox3.Text = ""
TextBox4.Text = ""
TextBox5.Text = ""
TextBox6.Text = ""
TextBox7.Text = ""
TextBox8.Text = ""
TextBox9.Text = ""
TextBox10.Text = ""
TextBox11.Text = ""
TextBox2.SetFocus
Else
Unload Me
End If
End Sub
Private Sub Exitform_Click()
End
End Sub
Sub ClearFields_Click()
For Each ctrl In Me.Controls
Select Case TypeName(ctrl)
Case "TextBox"
ctrl.Text = ""
End Select
Next ctrl
End Sub
Step 1: Create a Named Range
To simplify your code, I would create a NamedRange called CustomerIDList.
So, instead of saying:
Range("Customers!A8:A65536")
you'd be able to put:
Range("CustomerIDList")
In this picture the rows are hidden, but notice how the range selected is called CustomerIDList.
Then, when the UserForm is activated, it will use a function to return AA-66763 (one more than the max value in CustomerIDList)
Step 2: Use a custom function to split on hyphen
RegEx (Regular Expressions) could give you full control, but here's a solution using your own defined function.
This function relies on Excel's built-in FIND() function and uses VBA's Right() and Len() functions.
I'm assuming the following:
your Worksheet is named Customers
Range("A8") is where your values start (same as saying row 8, column 1)
Values in Column A are contiguous
Format of Values is AA-01234
For this function to work, it requires five inputs (i.e. arguments):
sheetName
nameOfRange
rowStart
colStart
delimeterToSplitOn
CustomerIDList is a name I chose for the Range, but it could be anything you want.
Private Sub UserForm_Activate()
TextBox1.Value = "AA-" & GetCustomerId("Customers", "CustomerIDList", 8, 1, "-")
End Sub
Public Function GetCustomerId( ByVal sheetName As String, ByVal nameOfRange As String, ByVal rowStart As Long, ByVal colStart As Long, ByVal delimeterToSplitOn) As Long
'Just creating a Range object, assigning it all the values of CustomerID, and naming the Range
Dim r1 As Range
Set r1 = Range(Cells(rowStart, colStart), Cells(rowStart, colStart).End(xlDown))
With ActiveWorkbook.Names
.Add Name:=nameOfRange, RefersTo:="=" & sheetName & "!" & r1.Address & ""
End With
'This array holds all original AlphaNumeric Values
Dim AlphaNumericArr() As Variant
'This array will hold only the Numeric Values
Dim NumericArr() As Variant
'Populate Array with all the values
AlphaNumericArr = Range(nameOfRange)
'Resize NumericArr to match the size of AlphaNumeric
'Notice, this is an index of 1 because row numbers start at 1
ReDim NumericArr(1 To UBound(AlphaNumericArr, 1))
Dim R As Long
Dim C As Long
For R = 1 To UBound(AlphaNumericArr, 1) ' First array dimension is rows.
For C = 1 To UBound(AlphaNumericArr, 2) ' Second array dimension is columns.
'Uses one worksheet function: FIND()
'Uses two VBA functions: Right() & Len()
'Taking the original value (i.e. AA-123980), splitting on the hyphen, and assigning remaining right portion to the NumericArr
NumericArr(R) = Right(AlphaNumericArr(R, C), Len(AlphaNumericArr(R, C)) - Application.WorksheetFunction.Find(delimeterToSplitOn, (AlphaNumericArr(R, C))))
Next C
Next R
'Now that have an array of all Numeric Values, find the max value and store in variable
Dim maxValue As Long
Dim i As Long
maxValue = NumericArr(1)
For i = 1 To UBound(NumericArr)
If maxValue < NumericArr(i) Then
maxValue = NumericArr(i)
End If
Next
'Add 1 to maxValue because it will show in UserForm for a new CustomerID
GetCustomerId = maxValue + 1
End Function
UPDATE:
This is how you would change your existing code so that it works. Notice, the MsgBox now shows the id, too.
Private Sub Addreccord_Click()
Dim LastRow As Object
Set LastRow = Range("CustomerIDList").End(xlDown)
LastRow.Offset(1, 0).Value = "AA-" & GetCustomerId("Customers", "CustomerIDList", 8, 1, "-")
LastRow.Offset(1, 1).Value = TextBox2.Text
LastRow.Offset(1, 2).Value = TextBox3.Text
LastRow.Offset(1, 3).Value = TextBox4.Text
LastRow.Offset(1, 4).Value = TextBox5.Text
LastRow.Offset(1, 5).Value = TextBox6.Text
LastRow.Offset(1, 6).Value = TextBox7.Text
LastRow.Offset(1, 7).Value = TextBox8.Text
LastRow.Offset(1, 8).Value = TextBox9.Text
LastRow.Offset(1, 9).Value = TextBox10.Text
LastRow.Offset(1, 10).Value = TextBox11.Text
MsgBox "One record added to Customers List. New Customer ID is " & LastRow.Offset(1, 0).Value
I shortened your code. I think your problem is in the Addreccord_Click() sub. Does this work for you?
Private Sub CommandButton1_Click()
Dim LastRow As Range
Set LastRow = Range("A8").End(xlDown)
LastRow.Offset(1, 0).Value = WorksheetFunction.Max(Range("Customers!A8:A65536")) + 1
LastRow.Offset(1, 1).Value = TextBox1.Text
MsgBox "One record added to Customers List"
response = MsgBox("Do you want to enter another record?", _
vbYesNo)
If response = vbYes Then
Else
Unload Me
End If
End Sub