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
Related
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
I need to merge the cells one above the months.
Cells Should be merged from 01 to 12 showing year in cell.
Look for the picture for more clarification.
I have below code, but which show months after run in cell row1.
My idea is to convert above cells to years through vba and apply merge same year at the end.
which is shown in desired output.
Note.
ROW 4 and 5 are just my thinking, which will help year to merge.
Dim a(), i As Long, j As Long, m As Long, x As Range
With Range("b1:qaz1")
.MergeCells = False
.ClearContents
a() = .Offset(1).Value
m = Month(a(1, 1))
j = UBound(a, 2)
Set x = .Cells(1)
For i = 2 To j
If m <> Month(a(1, i)) Or i = j Then
With Range(x, .Cells(i - IIf(i = j, 0, 1)))
.MergeCells = True
.HorizontalAlignment = xlCenter
End With
x.Value = Format(DateSerial(2000, m, 1), "MMMM")
m = Month(a(1, i))
Set x = .Cells(i)
End If
Next
End With
End Sub
After running new program output look like
Since you have true dates in your caption row the month and year can be extracted from there. However, the code below converts dates that might have been created using formulas to hard dates before processing them.
Sub MergeCaptionsByYear()
' 031
Const CapsRow As Long = 1 ' change to suit
Const StartClm As Long = 2 ' change to suit
Dim Rng As Range ' working range
Dim Tmp As Variant ' current cell's value
Dim Cl As Long ' last used column
Dim Cstart As Long ' first column in Rng
Dim C As Long ' working column
Dim Yr As Integer ' year
Cl = Cells(CapsRow, Columns.Count).End(xlToLeft).Column
Range(Cells(CapsRow, StartClm), Cells(CapsRow, Cl)).Copy
Cells(CapsRow, StartClm).PasteSpecial xlValues
Application.CutCopyMode = False
C = StartClm - 1
Application.DisplayAlerts = False
Do
Tmp = Cells(CapsRow, C + 1).Value
If Not IsDate(Tmp) And (C <> Cl) Then
MsgBox "Cell " & Cells(CapsRow, C + 1).Address(0, 0) & _
" doesn't contain a date." & vbCr & _
"This macro will be terminated.", _
vbInformation, "Invalid cell content"
Exit Do
End If
If (Yr <> Year(CDate(Tmp))) Or (C = Cl) Then
If Yr Then
Set Rng = Range(Cells(CapsRow, Cstart), _
Cells(CapsRow, C))
With Rng
.Merge
.HorizontalAlignment = xlCenter
.NumberFormat = "yyyy"
End With
SetBorder Rng, xlEdgeLeft
SetBorder Rng, xlEdgeRight
End If
If C > (Cl - 1) Then Exit Do
Cstart = C + 1
Yr = Year(Tmp)
End If
C = C + 1
Loop
Application.DisplayAlerts = True
End Sub
Private Sub SetBorder(Rng As Range, _
Bord As XlBordersIndex)
' 031
With Rng.Borders(Bord)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium ' xlThin
End With
End Sub
Assuming the months range is "B5:AH5"
Sub test()
Dim monthsRng As Range
Set monthsRng = Range("B5:AH5")
monthsRng.Cells(1, 1).Offset(-1, 0).Select
For j = 1 To Int((monthsRng.Cells.Count / 12) + 2)
If ActiveCell.Offset(1, 0) <> 0 Then
For i = 1 To 12
ActiveCell.Value = Year(ActiveCell.Offset(1, 0))
If Year(ActiveCell.Offset(1, i)) = ActiveCell Then
Selection.Resize(1, i + 1).Select
Else
Exit For
End If
Next
With Selection
.HorizontalAlignment = xlCenter
.MergeCells = True
End With
Selection.Offset(0, 1).Select
Else
Exit For
End If
Next
End Sub
Replacing the inner for loop with below code will work irrespective of whether the dates in the Range("B5:AH5") in above procedure are formatted as dates or not.
For i = 1 To 12
ActiveCell.Value = Right(Format(ActiveCell.Offset(1, 0), "DD.MM.YYYY"), 4)
If Right(Format(ActiveCell.Offset(1, i), "DD.MM.YYYY"), 4) = Format(ActiveCell, Text) Then
Selection.Resize(1, i + 1).Select
Else
Exit For
End If
Next
However, in any case you need to format the output in excel as number (without 1000 separator and decimal places) and not date.
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
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
I type three entries in specific cells
[A2,B2,C2] and run code to take this data to the first empty row in a table.
The code also prevents duplicates based on the entered value in cell B2. If it already exists in the range (B2:B5000) it prevent duplicates.
The problem is it does not ignore the case.
For example:
I enter value "Acetic Acid"
After awhile I add "acetic Acid" or change any letter case.
The code adds it normally without preventing.
How do I ignore the letter case?
Sub tarheel()
LastRow = Range("A10000").End(xlUp).Row + 1
LR = Range("b10000").End(xlUp).Row + 1
For r = 5 To LR
If Cells(r, 2) = Range("b2") Then MsgBox "This Item Name already exist, No shift will done": Exit Sub
Next
Cells(LastRow, 1).Value = Range("A2").Value
Cells(LastRow, 2).Value = Range("B2").Value
Cells(LastRow, 3).Value = Range("C2").Value
Range("A2:C2").Select
Selection.ClearContents
Range("A2").Select
End Sub
thanks for all your replies and i will try it too and give feedback to you.
i could figure it out by adding this line at the top of my module.
Option Compare Text
and it fixed my problem.
thanks
To change case in VBA, you have LCase and UCase, which will respectively change all of your string into lower case or upper case.
Here is your code with the change and got ride of the useless (and ressource-greedy) select at the end :
Sub tarheel()
LastRow = Range("A10000").End(xlUp).Row + 1
LR = Range("b10000").End(xlUp).Row + 1
IsIn = False
For r = 5 To LR
If LCase(Cells(r, 2)) = LCase(Range("b2")) Then _
MsgBox "This Item Name already exist, No shift will done": Exit Sub
Next
Cells(LastRow, 1).Value = Range("A2").Value
Cells(LastRow, 2).Value = Range("B2").Value
Cells(LastRow, 3).Value = Range("C2").Value
Range("A2:C2").ClearContents
'Range("A2").Select
End Sub
You can replace your loop that compares for existing values with a case insensitive one by forcing both values to either upper or lower case.
For r = 5 To LR
If lcase(Cells(r, 2)) = lcase(Range("b2")) Then
MsgBox "This Item Name already exist, No shift will done"
Exit Sub
end if
Next
It may be more efficient to use a case-insensitive worksheet function to check the whole range at once.
If cbool(application.countif(Range("B5:B" & LR), Cells(r, 2))) Then
MsgBox "This Item Name already exist, No shift will done"
Exit Sub
end if
Another possible:
If not iserror(application.match(Cells(r, 2), Range("B5:B" & LR), 0)) Then
MsgBox "This Item Name already exist, No shift will done"
Exit Sub
end if
Sub tarheel()
LastRow = Range("A10000").End(xlUp).Row + 1
LR = Range("b10000").End(xlUp).Row + 1
IsIn = False
For r = 5 To LR
If LCase(Cells(r, 2)) = LCase(Range("b2")) Then _
MsgBox "This Item Name already exist, No shift will done": Exit Sub
Next
Cells(LastRow, 1).Value = Range("A2").Value
Cells(LastRow, 2).Value = Range("B2").Value
Cells(LastRow, 3).Value = Range("C2").Value
Range("A2:C2").ClearContents
'Range("A2").Select
End Sub