Hi John,
If all you want to do is run a procedure if user manually inserted row(s)
all you really need is to trap the Row-Insert button's click event (XL2000
and later), but with an OnTime macro. Except there could be a problem if
user's insert fails, which it can for various reasons. Could maintain a
named cell low down and compare its previous and current row number.
Following attempts to return newly inserted rows by right clicking a row
header and insert button. It gets quite complicated if multiple areas of
rows are inserted, and even more so if user didn't select them in order from
top down.
This is probably overkill for your purposes but look at the button click and
include your own OnTime macro.
For testing newly inserted rows are coloured yellow -
Code in a normal module, ThisWorkBook and Class1
'''''' code in a normal module''''''''
'
' run SetBtnClick or switch sheets to get things going
Option Explicit
Dim cls As Class1
Public gRngRows() As Range
Public gsRowsAddr As String
Sub SetBtnClick()
If cls Is Nothing Then
Set cls = New Class1
Set cls.btn = CommandBars("Row").FindControl(ID:=3183)
'Debug.Print cls.btn.Caption '&Insert
End If
If TypeName(Selection) = "Range" Then
SetRows Selection
Else
ReDim gRngRows(0)
gsRowsAddr = ""
End If
End Sub
Sub SetRows(rTarget As Range)
Dim bEntrireRows As Boolean
Dim shtColCnt As Long, n As Long
Dim rng As Range
On Error GoTo errElse
shtColCnt = ActiveSheet.Columns.Count
For Each rng In rTarget.Areas
n = n + 1
bEntrireRows = rng.Columns.Count = shtColCnt
If Not bEntrireRows Then Exit For
Next
If bEntrireRows Then
gsRowsAddr = rng.Areas(1).Address
ReDim gRngRows(1 To n)
n = 0
For Each rng In Selection.Areas
n = n + 1
Set gRngRows(n) = rng.Offset(rng.Rows.Count)
' error if offset extends below sheet but can't insert rows
Next
End If
errElse:
If Err.Number Or Not bEntrireRows Then
ReDim gRngRows(0)
gsRowsAddr = ""
End If
End Sub
Sub GetNewRows()
Dim i As Long, n As Long
Dim rng As Range, rA As Range
Set rng = Selection
If gRngRows(1).Address <> gsRowsAddr Then
ReDim ord(1 To rng.Areas.Count, 0 To 1) As Long
i = 0
For Each rA In rng.Areas
i = i + 1
ord(i, 0) = i
ord(i, 1) = rA.Row
Next
'need to sort selected multiareas from top down
BubbleSort1 ord
Cells.Interior.ColorIndex = xlNone
For i = 1 To UBound(ord)
With rng.Areas(ord(i, 0))
Debug.Print "rows inserted " & .Offset(n).Address(0, 0)
.Offset(n).Interior.ColorIndex = 6
n = n + .Rows.Count
End With
Next
End If
SetRows rng
End Sub
Function BubbleSort1(arr() As Long)
Dim tmp0 As Long, tmp1 As Long
Dim i As Long
Dim b As Boolean
Do
b = True
For i = LBound(arr) To UBound(arr) - 1
If arr(i, 1) > arr(i + 1, 1) Then
b = False
tmp0 = arr(i, 0)
tmp1 = arr(i, 1)
arr(i, 0) = arr(i + 1, 0)
arr(i + 1, 0) = tmp0
arr(i, 1) = arr(i + 1, 1)
arr(i + 1, 1) = tmp1
End If
Next i
Loop While Not b
End Function
''''''''''''''''''end normal module code'''''''''''''''
'''''code in ThisWorbook module''''''''
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
SetBtnClick
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, _
ByVal Target As Range)
SetRows Target
End Sub
'''''end ThisWorkbook code''''''''''''''
''''' code in Class1 ''''''
Public WithEvents btn As CommandBarButton
Private Sub btn_Click(ByVal Ctrl As Office.CommandBarButton, _
CancelDefault As Boolean)
Application.OnTime Now, "GetNewRows"
End Sub
'''''end Class1 code'''''''''
This does not cater for other ways rows can be inserted
Regards,
Peter T
"John" <(E-Mail Removed)> wrote in message
news:FA13F958-4D75-4DF6-AF80-(E-Mail Removed)...
> Hi,
>
> I run a procedure in the Change Event, problem is, i only want this to
> happen when a row is inserted. Is it possibe to trap when a row is
inserted
> and then run the procedure?
>
> Thanks
>
> John
>
|
Similar Threads
