I am trying to make an excel file for my parents so that they have it easier than writing all the info in a book X amount of times.
i have A; B; C; D; E; F; G; H; I; J; and L columns and want to automate and duplicate the data in A to G in rows below xn-1 times when
there is a number on Hx cell x amount of times,
where x can be from 1 to 50.
https://preview.redd.it/8p19v7ncjyo91.png?width=1859&format=png&auto=webp&s=5265abb1f6c77b418c409197e19ab836f62bd5ec
before typing 10
https://preview.redd.it/xq9p3m69kyo91.png?width=1384&format=png&auto=webp&s=b06512811b45d8d7c33ff8072d58bc1f8603fa46
example data after inputting 10 or 5 respectively
thus will be inputting all the details in rows 17 and 27
Please, test the next code. It iterates backwards, inserts the necessary number of rows (from "H" cell) and copy on them the values of between columns "A:G" of the row where "H" cell is not empty and numeric:
Sub CopyRowsNTimes()
Dim sh As Worksheet, lastRH As Long, i As Long
Set sh = ActiveSheet 'use here the sheet you need
lastRH = sh.Range("H" & sh.rows.count).End(xlUp).row 'last row on column "H:H")
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For i = lastRH To 2 Step -1
If IsNumeric(sh.Range("H" & i).Value) And sh.Range("H" & i).Value <> "" Then
Application.CutCopyMode = False
sh.rows(i + 1 & ":" & i + sh.Range("H" & i).Value - 1).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
sh.Range("A" & i + 1, "G" & i + 1 + sh.Range("H" & i).Value - 2).Value = _
sh.Range("A" & i, "G" & i).Value
End If
Next i
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "Ready..."
End Sub
Please, send some feedback after testing it.
I think, clearing the content of H:H column after processing will be a good idea. For the case you run the code for the second time, by mistake. I let it as it was, only to easily check the inserted rows...
Duplicate Rows
Sheet Module e.g. Sheet1
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
DuplicateRows Target, "H2", 1, 50
End Sub
Standard Module e.g. Module1
Option Explicit
Sub DuplicateRows( _
ByVal TargetCell As Range, _
ByVal CriteriaColumnFirstCellAddress As String, _
Optional ByVal MinTargetValue As Long = 1, _
Optional ByVal MaxTargetValue As Long = 1)
Const ProcName As String = "DuplicateRows"
On Error GoTo ClearError
' Validate 'TargetCell'.
'If TargetCell Is Nothing Then Exit Sub
If TargetCell.Cells.CountLarge > 1 Then Exit Sub ' not a single cell
' Validate 'CriteriaColumnFirstCellAddress'.
Dim ws As Worksheet: Set ws = TargetCell.Worksheet
Dim fCell As Range
On Error Resume Next
Set fCell = ws.Range(CriteriaColumnFirstCellAddress)
On Error GoTo ClearError
If fCell Is Nothing Then Exit Sub ' invalid address
If fCell.Cells.CountLarge > 1 Then Exit Sub ' not a single cell
' Build the Criteria (one-column) range ('crg').
Dim rg As Range: Set rg = ws.UsedRange
Dim crg As Range
With fCell
Set crg = Intersect(rg, .Resize(ws.Rows.Count - .Row + 1))
End With
If crg Is Nothing Then Exit Sub ' not intersecting
If Intersect(TargetCell, crg) Is Nothing Then Exit Sub ' not intersecting
' Validate 'MinTargetValue' and 'MaxTargetValue'.
If MinTargetValue < 1 Then Exit Sub
If MaxTargetValue < 1 Then Exit Sub
Dim MinValue As Long
Dim MaxValue As Long
' Handle if min and max are switched.
If MinTargetValue < MaxTargetValue Then
MinValue = MinTargetValue
MaxValue = MaxTargetValue
Else
MinValue = MaxTargetValue
MaxValue = MinTargetValue
End If
' Validate the Target value.
Dim TargetValue As Variant: TargetValue = TargetCell.Value
If Not VarType(TargetValue) = vbDouble Then Exit Sub ' not a number
If Int(TargetValue) <> TargetValue Then Exit Sub ' not a whole number
Select Case TargetValue
Case MinValue To MaxValue
Case Else: Exit Sub ' exceeds the range of numbers
End Select
Dim rrg As Range: Set rrg = Intersect(rg, TargetCell.EntireRow)
Dim LastRow As Long: LastRow = crg.Cells(crg.Cells.Count).Row
Dim MaxInsertRows As Long: MaxInsertRows = ws.Rows.Count - LastRow
If TargetValue > MaxInsertRows Then Exit Sub ' doesn't fit in the worksheet
' (Insert) Copy the data.
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With rrg
If .Row < LastRow Then
.Offset(1).Resize(TargetValue).Insert _
Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
TargetCell.ClearContents
.Copy Destination:=.Resize(TargetValue + 1)
End With
ProcExit:
On Error Resume Next
With Application
If Not .EnableEvents Then .EnableEvents = True
If Not .ScreenUpdating Then .ScreenUpdating = True
End With
On Error GoTo 0
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
I have two BeforeDoublceClick events which i need help amalgamating, please can someone help me?
I want to amalgamate
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column <> 1 Then Exit Sub
Dim last As Long
last = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row
Sheet2.Range("A6:P" & last).AutoFilter
Sheet2.Range("A6:P" & last).AutoFilter Field:=1, Criteria1:=Target.Value
Cancel = True
Application.Goto Sheet2.Range("A1")
End Sub
and
If Target.Column <> 2 Then Exit Sub
Dim last As Long
last = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
Sheet1.Range("A6:AQ" & last).AutoFilter
Sheet1.Range("B6:AQ" & last).AutoFilter Field:=1, Criteria1:=Target.Value
Cancel = True
Application.Goto Sheet1.Range("B7")
End Sub
The two codes are basically the same except the goto at the end, right?
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not (Target.Column = 1 Or Target.Column = 2) Then Exit Sub
Dim last As Long
last = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
Sheet1.Range("A6:AQ" & last).AutoFilter
Sheet1.Range("A6:AQ" & last).AutoFilter Field:=1, Criteria1:=Target.Value
Cancel = True
If Target.Column = 1 Then
Application.Goto Sheet1.Range("A1")
Else
Application.goto Sheet1.range("B7")
End if
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim last As Long
If Target.Column = 1 Then
last = Me.Cells(Me.Rows.Count, "B").End(xlUp).Row
Me.Range("A6:AQ" & last).AutoFilter
Me.Range("A6:AQ" & last).AutoFilter Field:=1, Criteria1:=Target.Value
Cancel = True
Application.Goto Me.Range("A1")
ElseIf Target.Column = 2 Then
last = Me.Cells(Me.Rows.Count, "B").End(xlUp).Row
Me.Range("A6:AQ" & last).AutoFilter
Me.Range("B6:AQ" & last).AutoFilter Field:=1, Criteria1:=Target.Value
Cancel = True
Application.Goto Sheet1.Range("B7")
End If
End Sub
I found this code on this forum to log changes to multiple cells to a sheet called "LOG". Not sure how it work but it works great. However, the log showed in single cell on the "LOG" sheet. Is there a way to modify the code so information appear in "LOG" sheet in different row such as date/time in row A, user in row B, etc. Also, can I add to the code so that the sheet "LOG" is password protect from user (but still adding log). Here's the code. Thank you for any help.
Dim RangeValues As Variant
Dim lCols As Long, lRows As Long
Private Sub Worksheet_Change(ByVal Target As Range)
Dim UN As String: UN = Application.UserName
If Target.Cells.Count = 1 Then
If Target.Value <> RangeValues Then
Sheets("LOG").Cells(65000, 1).End(xlUp).Offset(1, 0).Value = Now & " / " & UN & " / changed cell " & Target.Address & " /from/ " & RangeValues & " to " & Target.Value
End If
Exit Sub
End If
' More than one cell in the range
Dim r As Long, c As Long
For r = 1 To lRows
For c = 1 To lCols
If Target.Cells(r, c).Value <> RangeValues(r, c) Then
Sheets("LOG").Cells(65000, 1).End(xlUp).Offset(1, 0).Value = Now & " / " & UN & " / changed cell " & Target.Cells(r, c).Address & " /from/ " & RangeValues(r, c) & " to " & Target.Cells(r, c).Value
End If
Next c
Next r
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
RangeValues = Target.Value
lCols = Target.Columns.Count
lRows = Target.Rows.Count
End Sub
Please, test the next updated solution:
Option Explicit
Dim RangeValues As Variant
Dim lCols As Long, lRows As Long
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sh As Worksheet: Set sh = Sheets("LOG_")
Dim UN As String: UN = Application.userName
If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 5) = Array("Time", "User Name", "Changed cell", "From", "To")
sh.Unprotect "1234" 'use here your real password
If Target.cells.Count = 1 Then
If Target.value <> RangeValues Then
sh.cells(rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 5).value = _
Array(Now, UN, Target.Address(0, 0), RangeValues, Target.value)
End If
Exit Sub
End If
' More than one cell in the range
Dim r As Long, c As Long
For r = 1 To lRows
For c = 1 To lCols
If Target.cells(r, c).value <> RangeValues(r, c) Then
sh.cells(rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 5).value = _
Array(Now, UN, Target.cells(r, c).Address(0, 0), RangeValues(r, c), Target.cells(r, c).value)
End If
Next c
Next r
sh.Protect "1234"
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
RangeValues = Target.value
lCols = Target.Columns.Count
lRows = Target.rows.Count
End Sub
In fact, only Worksheet_Change event has been changed and added Option Explicit on top of the module.
Edited:
Please, use the next code. It uses only an event and no necessary to previously select the range where to copy:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RangeValues As Variant, lCols As Long, lRows As Long
Dim sh As Worksheet: Set sh = Sheets("LOG_")
Dim UN As String: UN = Application.userName
If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 5) = Array("Time", "User Name", "Changed cell", "From", "To")
sh.Unprotect "1234" 'use here your real password
Dim TgValue 'the array to keep Target values (before UnDo)
Application.ScreenUpdating = False 'to optimize the code (make it faster)
Application.Calculation = xlCalculationManual
TgValue = Target.value
Application.EnableEvents = False
Application.Undo
RangeValues = Range(Target.Address).value 'define the RangeValue
lCols = Target.Columns.Count
lRows = Target.rows.Count
Range(Target.Address).value = TgValue 'Put back the Target value (changed using UnDo)
Application.EnableEvents = True
'One cell in the range
If Target.cells.Count = 1 Then
If Target.value <> RangeValues Then
sh.cells(rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 5).value = _
Array(Now, UN, Target.Address(0, 0), RangeValues, Target.value)
End If
sh.Protect "1234"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
End If
' More than one cell in the range
Dim r As Long, c As Long
For r = 1 To lRows
For c = 1 To lCols
If Target.cells(r, c).value <> RangeValues(r, c) Then
sh.cells(rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 5).value = _
Array(Now, UN, Target.cells(r, c).Address(0, 0), RangeValues(r, c), Target.cells(r, c).value)
End If
Next c
Next r
sh.Protect "1234"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Second edit:
The version able to deal with continuous ranges, but built by consecutively selecting cells:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RangeValues As Variant, lCols As Long, lRows As Long, contRng As Range
Dim sh As Worksheet: Set sh = Sheets("LOG_")
Dim UN As String: UN = Application.userName
If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 5) = Array("Time", "User Name", "Changed cell", "From", "To")
sh.Unprotect "" 'use here your real password
Dim TgValue 'the array to keep Target values (before UnDo)
Application.ScreenUpdating = False 'to optimize the code (make it faster)
Application.Calculation = xlCalculationManual
If Target.cells.Count > 1 Then
TgValue = Range(Target.Address).value
If Not IsArray(TgValue) Then 'if the range is discontinuous and its first area means single cell
Set contRng = ContRange(Target) 'the discontinuous range is transformed in continuous
TgValue = contRng.value 'only now the range value can be (correctly) put in an array
Set Target = contRng 'the target range is also built as continuous
' Debug.Print "Target = " & Target.Address: 'Stop
Else
Set contRng = Target 'for continuous ranges, even made of a single cell
End If
Else
TgValue = Target.value 'put the target range in an array (or as a string for a single cell)
Set contRng = Target 'set contRng (to be used later) as Target
End If
Application.EnableEvents = False 'avoiding to trigger the change event after UnDo
Application.Undo
RangeValues = Range(contRng.Address).value 'define the RangeValue
'If IsArray(RangeValues) Then Debug.Print RangeValues(1, 1): ' Stop
lCols = Target.Columns.Count 'extract the target number of rows and columns:
lRows = Target.rows.Count
Range(Target.Address).value = TgValue 'Put back the Target value (changed using UnDo)
Application.EnableEvents = True
'One cell in the range
If Target.cells.Count = 1 Then
If Target.value <> RangeValues Then
sh.cells(rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 5).value = _
Array(Now, UN, Target.Address(0, 0), RangeValues, Target.value)
End If
sh.Protect ""
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
End If
' More than one cell in the range
Dim r As Long, c As Long
For r = 1 To lRows
For c = 1 To lCols
If Target.cells(r, c).value <> RangeValues(r, c) Then
sh.cells(rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 5).value = _
Array(Now, UN, Target.cells(r, c).Address(0, 0), RangeValues(r, c), Target.cells(r, c).value)
End If
Next c
Next r
sh.Protect ""
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Function ContRange(rng As Range) As Range
Dim a As Range, rngCont As Range
For Each a In rng.Areas
If rngCont Is Nothing Then
Set rngCont = a
Else
Set rngCont = Union(rngCont, a)
End If
Next
If Not rngCont Is Nothing Then Set ContRange = rngCont
End Function
The code can be adapted to also handle real discontinue ranges, but it is a little more complicated and no interested in taking such a challenge...
Third edit:
The next version, follow a different logic and is able to log all kind of modifications, even in discontinuous ranges:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RangeValues As Variant, r As Long, boolOne As Boolean, TgValue 'the array to keep Target values (before UnDo)
Dim sh As Worksheet: Set sh = Sheets("LOG_")
Dim UN As String: UN = Application.userName
If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 6) = _
Array("Time", "User Name", "Changed cell", "From", "To", "Sheet Name")
sh.Unprotect "" 'use here your real password
Application.ScreenUpdating = False 'to optimize the code (make it faster)
Application.Calculation = xlCalculationManual
If Target.cells.count > 1 Then
TgValue = extractData(Target)
Else
TgValue = Array(Array(Target.value, Target.Address(0, 0))) 'put the target range in an array (or as a string for a single cell)
boolOne = True
End If
Application.EnableEvents = False 'avoiding to trigger the change event after UnDo
Application.Undo
RangeValues = extractData(Target) 'define the RangeValue
putDataBack TgValue, ActiveSheet 'put back the changed data
If boolOne Then Target.Offset(1).Select
Application.EnableEvents = True
For r = 0 To UBound(RangeValues)
If RangeValues(r)(0) <> TgValue(r)(0) Then
sh.cells(rows.count, 1).End(xlUp).Offset(1, 0).Resize(1, 6).value = _
Array(Now, UN, RangeValues(r)(1), RangeValues(r)(0), TgValue(r)(0), Target.Parent.Name)
End If
Next r
sh.Protect ""
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub putDataBack(arr, sh As Worksheet)
Dim i As Long, arrInt, El
For Each El In arr
sh.Range(El(1)).value = El(0)
Next
End Sub
Function extractData(rng As Range) As Variant
Dim a As Range, arr, count As Long, i As Long
ReDim arr(rng.cells.count - 1)
For Each a In rng.Areas
For i = 1 To a.cells.count
arr(count) = Array(a.cells(i).value, a.cells(i).Address(0, 0)): count = count + 1
Next
Next
extractData = arr
End Function
I´m trying to sort columns by value set in a drop down list.
I have got it to work for one column.
Value set in cell: B1
Sort Column A from A5 and hide cells not containing that value.
But I want to be able to sort multiple columns (A, B and C)via value in B1 and hide all rows not containing that specific value. See attatched image. Link:
https://i.stack.imgur.com/9NqC3.png
The working code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B1")) Is Nothing Then
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
If Len(Range("B1").Value) > 0 Then Range("A5", Range("A" & Rows.Count).End(xlUp)).AutoFilter Field:=1, Criteria1:=Range("B1").Value
End If
End Sub
Please, try the next adapted code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastR As Long, C As Range, rngDel As Range
If Target.Address = "$B$1" Then
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
If Target.Value <> "" Then
lastR = Me.Range("A" & Rows.count).End(xlUp).row
With Me.Range("A5:C" & lastR)
.AutoFilter field:=1, Criteria1:=Target.Value
For Each C In Me.Range("B6:C" & lastR)
If C.Value = Target.Value Then
If rngDel Is Nothing Then
Set rngDel = C
Else
Set rngDel = Union(rngDel, C)
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.EntireRow.Hidden = False
End With
End If
End If
End Sub
Edited:
The following code works when your last workbook structure. Please, try learning and understanding it:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastR As Long, C As Range, rngDel As Range
If Target.Address = "$E$1" Then
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
If Target.Value <> "" Then
lastR = Me.Range("B" & Rows.Count).End(xlUp).Row
With Me.Range("G1:J" & lastR)
.AutoFilter field:=1, Criteria1:=Target.Value
For Each C In Me.Range("G2:J" & lastR)
If C.Value = Target.Value Then
If rngDel Is Nothing Then
Set rngDel = C
Else
Set rngDel = Union(rngDel, C)
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.EntireRow.Hidden = False
End With
End If
End If
End Sub
You must use a complete filled column in order to calculate the last filled row!
The above code uses B:B column.
I'm having a problem with a macro because it give me Ambiguous name detected Worksheet_Change . If the user enter a value on any cell under column B it will run automatically a macro and if the user enter a value on column F it will run automatically another macro but I do not know how to fix this error . Please the the code below
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("B")) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
Dim rng As Range
For Each rng In Intersect(Target, Columns("B"))
If rng.Row > 2 Then ' your sample code seemed to suggest that this should start on row 3 and higher
Call MyMacro(rng.Row)
End If
Next rng
End If
Safe_Exit:
Application.EnableEvents = True
End Sub
Sub MyMacro(rw As Long)
If Range("B" & rw) = "" Then
MsgBox "Ingrese El account Number"
Else
Range("J" & rw & ":K" & rw) = Range("J" & rw & ":K" & rw).Value
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("F")) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
Dim rng As Range
For Each rng In Intersect(Target, Columns("F"))
If rng.Row > 3 Then ' your sample code seemed to suggest that this should start on row 3 and higher
Call Foolish(rng.Row)
End If
Next rng
End If
Safe_Exit:
Application.EnableEvents = True
End Sub
Sub Foolish(rw As Long)
If Range("F" & rw) = "" Then
MsgBox "Ingrese El account Number"
Else
Range("G" & rw & ":H" & rw) = Range("G" & rw & ":H" & rw).Value
End If
End Sub
You have two Worksheet_change() subs happening in your sheet. Copy the contents of one of those subroutines and paste it inside the other one so there is only one worksheet_change event.
For example:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("B")) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
Dim rng As Range
For Each rng In Intersect(Target, Columns("B"))
If rng.Row > 2 Then ' your sample code seemed to suggest that this should start on row 3 and higher
Call MyMacro(rng.Row)
End If
Next rng
End If
If Not Intersect(Target, Columns("F")) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
Dim rng As Range
For Each rng In Intersect(Target, Columns("F"))
If rng.Row > 3 Then ' your sample code seemed to suggest that this should start on row 3 and higher
Call Foolish(rng.Row)
End If
Next rng
End If
Safe_Exit:
Application.EnableEvents = True
End Sub
Sub MyMacro(rw As Long)
If Range("B" & rw) = "" Then
MsgBox "Ingrese El account Number"
Else
Range("J" & rw & ":K" & rw) = Range("J" & rw & ":K" & rw).Value
End If
End Sub