Picking list in Excel VBA - excel

I would like to create a picking list template for a logistic process in a warehouse. Following is the planned structure:
row1: header
scanned data: part number (column A), quantity (column B), location (column C)
timestamp of scanning automatically entered in column D when quantity scanned
all the cells are protected except of scanned data
one picking list contains max. 10 rows, then
save the file with timestamp (in xls, txt, csv etc. format): picking_list_ddmmyy_hhmm.ext,
print 3 copies on default printer,
and re-open the blank sheet for another scanning.
if picking list is shorter than 10 rows, option need to print it manually. when Print button pressed, then
save the file with timestamp (in xls, txt, csv etc. format): picking_list_ddmmyy_hhmm.ext,
print 3 copies on default printer,
and re-open the blank sheet for scanning.
I am here with the project (being a enthusiastic beginner I used different google findings, but I am stuck):
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Count = 1 And Target(1).Value <> "" Then
Range("A" & Target.Row + 1).Select
Dim x As Integer
For x = 2 To 1000
If Cells(x, 3).Value <> "" And Cells(x, 4).Value = "" Then
Cells(x, 4).Value = Date & " " & Time
Cells(x, 4).NumberFormat = "mm/dd/yyyy hh:mm:ss"
End If
Next
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With ActiveSheet.Shapes("Gomb 3")
.Top = Target.Offset(1).Top
.Left = Target.Offset(, 1).Left
End With
End Sub
Sub PrintScreen()
ActiveSheet.PrintOut Copies:=2, Collate:=True
End Sub
Can you please help me to complete the task as described above?

See below - not heavily commented but ask if there's anything you can't figure out.
Option Explicit
Const NUM_COLS As Long = 4 'how many data columns
Const MAX_ROWS As Long = 10
Const RW_START As Long = 2 'first row of scans starts here
Const COL_QUANT As Long = 3 'quantity col
Const COL_TMSTMP As Long = 4 'timestamp column
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
If Target.Column = COL_QUANT And Target.Row >= RW_START Then
With Target.EntireRow
If Len(.Cells(COL_QUANT).Value) > 0 And _
Len(.Cells(COL_TMSTMP).Value) = 0 Then
TimeStamp .Cells(COL_TMSTMP)
End If
End With
End If
'filled max number of rows?
If Application.CountA(Me.Cells(RW_START, COL_TMSTMP).Resize(MAX_ROWS)) = MAX_ROWS Then
SavePrintClear
End If
End Sub
'add a timestamp to a cell
Sub TimeStamp(c As Range)
With c
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
.Value = Now
End With
End Sub
Sub SavePrintClear()
Dim wb As Workbook
Set wb = Workbooks.Add()
With Me.Range("A1").Resize(MAX_ROWS + 1, NUM_COLS) 'include headers
.Copy wb.Sheets(1).Range("A1")
'.PrintOut Copies:=2, Collate:=True
.Offset(1, 0).ClearContents
End With
wb.SaveAs ThisWorkbook.Path & "\Saved\Scans_" & _
Format(Now, "yyyymmdd_hhmmss") & ".xlsx"
wb.Close False
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With ActiveSheet.Shapes("Gomb 3")
.Top = Target.Offset(1).Top
.Left = Target.Offset(, 1).Left
End With
End Sub
Sub PrintScreen()
ActiveSheet.PrintOut Copies:=2, Collate:=True
End Sub

Related

How do I select specific rows of a change log (VBA) based on criteria to be displayed in another table?

I'm very new to VBA and have been trying to code a large table which populates as changes are made to a main dashboard. It should populate each row with the date/time, user, change type, project #, old/new values, and notes on why...
I have gotten far enough to actually have this portion functioning although I am running into issues when trying to display certain rows based on criteria. For example one of my sheets displays project specific information based on the project number selected from a drop-down. Is it possible to have this also fetch all of the change log entries related to this project and display them in a table on that sheet?
Also I have a main sheet that I want to display only the last week of changes.
Here is the code I have so far:
Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("D10:W100")) Is Nothing Then
If Target.Count > 1 Then
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
End
End If
If ActiveSheet.Name = "Tender-Engineering" Then
Range("U2").Value = Target.Address
Range("U6").Value = InputBox("Please provide reasoning for the proposed change.", "Notes", "Type here")
AddToLog
End If
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("D10:W100")) Is Nothing Then
Range("U3").Value = Target.Value
Range("U4").Value = Target.Row
Range("U5").Value = Target.Column
End If
End Sub
Sub AddToLog()
Dim ActRow, Row, Column, LogRow As Long
Dim changeType As String
With Sheet4
ActRow = .Range("U2").Value
LogRow = Sheet2.Range("E9999").End(xlUp).Row + 1
Sheet2.Range("E" & LogRow).Value = Now
Sheet2.Range("F" & LogRow).Value = Application.UserName
Sheet2.Range("G" & LogRow).Value = .Range("U2").Value
Row = .Range("U4").Value
Sheet2.Range("H" & LogRow).Value = .Range("A" & Row).Value
Column = .Range("U5").Value
If Column >= 4 And Column <= 5 Then
changeType = "Management"
ElseIf Column >= 6 And Column <= 18 Then
changeType = "Schedule"
ElseIf Column >= 19 And Column <= 23 Then
changeType = "Budget"
End If
Sheet2.Range("I" & LogRow).Value = changeType
Sheet2.Range("J" & LogRow).Value = .Range("U3").Value
Sheet2.Range("K" & LogRow).Value = .Range(.Range("U2").Value).Value
Sheet2.Range("L" & LogRow).Value = .Range("U6").Value
End With
End Sub

How do I code my userform to insert the specified number of rows beneath the selected cell?

I have a userform that I've created that first asks how many rows I would like to insert. The next part of the userform asks what values I would like in columns 1 and 32 of each newly created row (I've set it up so that a maximum of 6 new rows can be created at one time). My data has 45 columns, and the only data that I want to change in the newly created rows is the data in the two columns i said earlier (1 and 32). I want the data from all the other columns from the original row to be copied down into each new row. My problem is that I can't seem to figure out how to write a code that will do this the way I want it. To provide an example, if I respond to the userform that I want to add 3 rows below the currently active cell, it will then ask me what values i want to enter for columns 1 and 32 for each of these new rows. So I would enter something like this:
First New Row
Column 1: 8/17/2019
Column 32: 400
Second New Row
Column 1: 8/10/2019
Column 32: 500
Third New Row
Column 1: 8/3/2019
Column 32: 600
I've tried many different codes but I've only really figured out how to write it so that it inserts one row below the active cell and its completely blank, I don't know how to program it so that it enters he values I selected for columns 1 and 32 and copies all other data down from the original row. I've figured out the code for the clear and cancel button on my userform already, I am now only concerned with writing this code for the "OK" button.
Private Sub CancelButton_Click()
Unload Me
End Sub
Private Sub ClearButton_Click()
Call UserForm_Initialize
End Sub
Private Sub OKButton_Click()
Dim lRow As Long
Dim lRsp As Long
On Error Resume Next
lRow = Selection.Row()
lRsp = MsgBox("Insert New row above " & lRow & "?", _
vbQuestion + vbYesNo)
If lRsp <> vbYes Then Exit Sub
Rows(lRow).Select
Selection.Copy
Rows(lRow + 1).Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Rows(lRow).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone
End Sub
Private Sub UserForm_Initialize()
AddRowsTextBox.Value = ""
Date1TextBox.Value = ""
Date2TextBox.Value = ""
Date3TextBox.Value = ""
Date4TextBox.Value = ""
Date5TextBox.Value = ""
Date6TextBox.Value = ""
Qty1TextBox.Value = ""
Qty2TextBox.Value = ""
Qty3TextBox.Value = ""
Qty4TextBox.Value = ""
Qty5TextBox.Value = ""
Qty6TextBox.Value = ""
End Sub
what i understand from your requirement, I would have add one more spin button on the form to make it user friendly. It may look like this.
User form Code may please be modified according to control names in your form
Option Explicit
Public Bal As Double, XQnty As Double, LargeOrder As Double, Sm As Double
Private Sub CommandButton1_Click()
Dim lRow As Long
Dim lRsp As Long
lRow = ActiveCell.Row()
lRsp = MsgBox("Insert New row Below " & lRow & "?", vbQuestion + vbYesNo)
If lRsp <> vbYes Then Exit Sub
Dim Ws As Worksheet
Dim R As Long, i As Integer, RowtoAdd As Integer
Set Ws = ThisWorkbook.ActiveSheet
RowtoAdd = Me.SpinButton1.Value
R = ActiveCell.Row
With Ws
.Cells(R, 32).Value = LargeOrder
For i = 1 To RowtoAdd
.Cells(R + 1, 1).EntireRow.Insert Shift:=xlDown
.Cells(R, 1).EntireRow.Copy Destination:=.Cells(R + 1, 1)
.Cells(R + 1, 1).Value = Me.Controls("TextBox" & i).Value
.Cells(R + 1, 32).Value = Me.Controls("TextBox" & 7 + i).Value
R = R + 1
Next i
End With
Unload Me
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub SpinButton1_Change()
Dim x As Integer, i As Integer, Y As Double
Me.TextBox7.Value = Me.SpinButton1.Value
x = Me.SpinButton1.Value
Sm = 0
For i = 1 To 6
Me.Controls("TextBox" & i).BackColor = IIf(i <= x, RGB(255, 100, 100), RGB(255, 2550, 255))
Me.Controls("TextBox" & i + 7).Value = IIf(i <= x, Int(Bal / x), 0)
Sm = Sm + IIf(i <= x, Int(Bal / x), 0)
Next
If Sm <> Bal Then
Me.TextBox8.Value = Int(Bal / x) + Bal - Sm
End If
ManualBal
End Sub
Private Sub TB_LO_Change()
LargeOrder = Val(Me.TB_LO.Value)
Bal = XQnty - LargeOrder
ManualBal
End Sub
Private Sub UserForm_Initialize()
Dim i As Integer, dx As Variant
Me.SpinButton1.Value = 1
Me.TextBox7.Value = 1
Me.TextBox1.BackColor = RGB(255, 100, 100)
dx = ThisWorkbook.ActiveSheet.Cells(ActiveCell.Row, 1).Value
XQnty = ThisWorkbook.ActiveSheet.Cells(ActiveCell.Row, 32).Value
LargeOrder = 575
Bal = XQnty - LargeOrder
Sm = 0
If IsDate(dx) = False Then dx = Now()
For i = 1 To 6
Me.Controls("TextBox" & i).Value = Format(dx - i * 7, "mm-dd-yyyy")
Sm = Sm + Int(Bal / 6)
Me.Controls("TextBox" & i + 7).Value = Int(Bal / 6)
Next
If Sm <> Bal Then
Me.TextBox8.Value = Int(Bal / 6) + Bal - Sm
End If
Me.TB_LO = LargeOrder
Me.TB_Bal = 0
End Sub
Private Sub ManualBal()
Dim x As Integer, i As Integer
x = Me.SpinButton1.Value
Bal = XQnty - LargeOrder
Sm = 0
For i = 1 To 6 ' Or may use 6 insted of X
Sm = Sm + Val(Me.Controls("TextBox" & i + 7).Value)
Next
Me.TB_Bal.Value = Bal - Sm
End Sub
Private Sub TextBox8_Exit(ByVal Cancel As MSForms.ReturnBoolean)
ManualBal
End Sub
Private Sub TextBox9_Exit(ByVal Cancel As MSForms.ReturnBoolean)
ManualBal
End Sub
Private Sub TextBox10_Exit(ByVal Cancel As MSForms.ReturnBoolean)
ManualBal
End Sub
Private Sub TextBox11_Exit(ByVal Cancel As MSForms.ReturnBoolean)
ManualBal
End Sub
Private Sub TextBox12_Exit(ByVal Cancel As MSForms.ReturnBoolean)
ManualBal
End Sub
Private Sub TextBox13_Exit(ByVal Cancel As MSForms.ReturnBoolean)
ManualBal
End Sub
Here Text Box 1 to 6 for dates, 7 for Spin Button values and Text Box 8 to 13 for quantity. May please either modify code according to control names Or modify Control names according to code.
Edit: Two new Text Box added named TB_BAL to show when entering values in manually in Quantity text boxes (balance calculated only at exit event of text boxes) and TB_LO to change LargeOrder during run.

Selecting column range with specific header

I have a macro code but it runs on specific column and on range of 500 only. I wish it should dynamically select column of header 'PRODUCTS' is present. if possible can we increase the limit of 500 to all the data present in column 'PRODUCTS'.
Sub Pats()
myCheck = MsgBox("Do you have Patent Numbers in Column - B ?", vbYesNo)
If myCheck = vbNo Then Exit Sub
endrw = Range("B500").End(xlUp).Row
Application.ScreenUpdating = False
For i = 2 To endrw
PatNum = Cells(i, 2).Value
If Left(Cells(i, 2), 2) = "US" Then
link = "http://www.google.com/patents/" & PatNum
Cells(i, 2).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="http://www.google.com/patents/" & PatNum, ScreenTip:="Click to View", TextToDisplay:=PatNum
With Selection.Font
.Name = "Arial"
.Size = 10
End With
ElseIf Left(Cells(i, 2), 2) = "EP" Then
link = "http://www.google.com/patents/" & PatNum
Cells(i, 2).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="http://www.google.com/patents/" & PatNum, ScreenTip:="Click to View", TextToDisplay:=PatNum
With Selection.Font
.Name = "Arial"
.Size = 10
End With
End If
Next i
End Sub
I would first extract the link building part into a separate subroutine ...
Sub AddLink(c As Range)
Dim link As String
Dim patNum As String
Dim test As String
patNum = c.Value
test = UCase(Left(patNum, 2))
If test = "US" Or test = "EP" Then
link = "http://www.google.com/patents/" & patNum
Else
link = "http://www.www.hyperlink.com/" & patNum
End If
c.Hyperlinks.Add Anchor:=c, Address:=link, ScreenTip:="Click to View", TextToDisplay:=patNum
With c.Font
.Name = "Arial"
.Size = 10
End With
End Sub
Then I would add a function to find the column...
Function FindColumn(searchFor As String) As Integer
Dim i As Integer
'Search row 1 for searchFor
FindColumn = 0
For i = 1 To ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column
If ActiveSheet.Cells(1, i).Value = searchFor Then
FindColumn = i
Exit For
End If
Next i
End Function
Finally I would put it all together ...
Sub Pats()
Dim col As Integer
Dim i As Integer
col = FindColumn("PRODUCTS")
If col = 0 Then Exit Sub
For i = 2 To ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
AddLink ActiveSheet.Cells(i, col)
Next i
End Sub
I'll admit I have to use SO to remind myself how to get the last used cell on a worksheet (see Find Last cell from Range VBA).
The code below will find which column has the header PRODUCTS and then find the last row in that column and store it in variable lrProdCol.
Sub FindProductLR()
Dim col As Range
Dim endrw As Long
Set col = Rows(1).Find("PRODUCTS")
If Not col Is Nothing Then
endrw = Cells(Rows.count, col.Column).End(xlUp).Row
Else
MsgBox "The 'PRODUCTS' Column was not found in row 1"
End If
End Sub
So replace the following bit of code
myCheck = MsgBox("Do you have Patent Numbers in Column - B ?", vbYesNo)
If myCheck = vbNo Then Exit Sub
endrw = Range("B500").End(xlUp).Row
With the lines above. Hope that helps

WorksheetChange Event to Concatenate Row and First Letter of First Name + First Letter of Last Name

I think the code should be something like this, but I'm getting an error on this line where I am trying to handle the first and last names. Basically, I want to create a code in Column A, which is the first letter of the person's first name and first letter of the person's last name, concatenated with the row number. The row will be the active row (always Column A) and the first and last names will be stored in Column B.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub
On Error GoTo ErrHandler
Application.EnableEvents = False
If Target.Column = 1 Then
Target.Offset(0, 0).FormulaR1C1 = "=ROW()"
TV1 = Target.Offset(0, 0).FormulaR1C1
Target.Offset(0, 0).FormulaR1C1 = "=UPPER(LEFT(R[" & "=ROW()" & "]C[1],1)&MID(R[" & "=ROW()" & "]C[1],FIND("" "",R[" & "=ROW()" & "]C[1],1)+1,1))"
TV2 = Target.Offset(0, 0).FormulaR1C1
Target.Offset(0, 0).Value = TV2 & "-" & TV1
End If
End Sub
I don't like to avoid dealing with more than a single cell as the Target. It isn't hard to deal with multiple cells.
After disabling events and performing your processing, you are not turning them back on again. You code will only run once without manually turning events back on.
If you are putting first and last names into column B, shouldn't the processing be subject to column B and not column A?
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("B")) Is Nothing Then
On Error GoTo ErrHandler
Application.EnableEvents = False
Dim trgt As Range
For Each trgt In Intersect(Target, Target.Parent.UsedRange, Columns("B"))
trgt = StrConv(Trim(trgt.Value2), vbProperCase)
If CBool(InStr(2, trgt.Value2, Chr(32))) Then
trgt.Offset(0, -1) = _
UCase(Left(trgt.Value2, 1)) & _
UCase(Mid(trgt.Value2, InStr(1, trgt.Value2, Chr(32)) + 1, 1)) & _
Format(trgt.Row, "000")
End If
Next trgt
End If
ErrHandler:
Application.EnableEvents = True
End Sub
I've added some trim and proper-case conversion to auto-correct the values being typed into column B.
In the following image, I copied the names from G5:G8 and pasted them into B2:B5.
I would do this differently. Why write formulas when you can do it simply in VBA?
I've made some annotations to your original code also:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub
Application.EnableEvents = False
' No error handler in your code
'On Error GoTo ErrHandler
' don't need to check if column 1 since we already did that and exited the sub if it was not
' If Target.Column = 1 Then
'Target.Offset(0,0) = Target
'Target.Offset(0, 0).FormulaR1C1 = "=ROW()"
'TV1 = Target.Offset(0, 0).FormulaR1C1
'Target.Offset(0, 0).FormulaR1C1 = "=UPPER(LEFT(R[" & "=ROW()" & "]C[1],1)&MID(R[" & "=ROW()" & "]C[1],FIND("" "",R[" & "=ROW()" & "]C[1],1)+1,1))"
'TV2 = Target.Offset(0, 0).FormulaR1C1
'Target.Offset(0, 0).Value = TV2 & "-" & TV1
'Just do the creation in VB
With Target
.Value = .Row & Left(.Offset(0, 1), 1) & Left(Split(.Offset(0, 1))(1), 1)
End With
'If you have more than two space-separated words in the name, then something like
Dim V As Variant
With Target
V = Split(.Offset(0, 1))
.Value = .Row & Left(V(0), 1) & Left(V(UBound(V)), 1)
End With
'Don't forget to reenable events
Application.EnableEvents = True
End Sub
Also, since the names are in Column B, why are you testing for a change in Column A? There could be reasons, but if there are not, it might be smoother to check for changes in column B.
I figured it out!!
If Target.Column = 1 Then
Target.Offset(0, 0).FormulaR1C1 = "=ROW()"
TV1 = Target.Value
Target.Offset(0, 0).FormulaR1C1 = "=UPPER(LEFT(RC[1],1)&MID(RC[1],FIND("" "",RC[1],1)+1,1))"
TV2 = Target.Value
Target.Value = TV2 & "-" & TV1
End If

Insert columns based on input in C3 and copy all column values

I Have a worksheet in which we need to automate the number of column entries based on the number of units required.
The cells in each row have formulas based on input parameters and subtotals. The requirement is to insert defined number of columns based on the units required (can be input box or cell reference) which should result in copying all formulas and formats to all columns inserted. The inserted columns should be before the last three columns namely Total, Budget and Variance.
I have found the below code but this is not working for my example.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LC As Integer
Dim I As Integer
Application.ScreenUpdating = False
If Target.Address <> "$C$3" Then Exit Sub
If Target.Value = "" Or Target.Value = 0 Then MsgBox "Value must be superior to 0": Exit Sub
LC = Cells(2, Application.Columns.Count).End(xlToLeft).Column
If LC = 5 Then
If Target.Value = 1 Then
Exit Sub
Else
For I = 2 To Target.Value
Columns(4).Copy
Columns(I + 3).Insert Shift:=xlToRight
Cells(2, I + 3).Value = "Unit " & I
Cells(3, I + 3) = I
Next I
End If
Application.CutCopyMode = False
Exit Sub
End If
Range(Cells(2, 5), Cells(2, LC - 1)).EntireColumn.Delete
For I = 2 To Target.Value
Columns(4).Copy
Columns(I + 3).Insert Shift:=xlToRight
Cells(2, I + 3).Value = "Unit " & I
Cells(3, I + 3) = I
Next I
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Kindly help me with a solution to this problem.
Please let me know how I can send the worksheet for your reference.
Thanks,
Best regards,
Thomas

Resources