Free Microsoft Excel 2013 Quick Reference

VBA shift / offset range down after new rows added

I have two sheets in my workbook, one pulling data from SQL (SQLDATA) and the other is that data copied/pasted plus manually added comments in the 2 columns to the right (USER).
The data comes out of SQL already sorted with the latest week's information first and I have set up an advanced filter in (USER) so that only information from the latest week is shown.
The problem that I have is that the comments which were made about the previous week (when that was at the top) don't get shifted down when I paste in the refreshed data.

My idea was to count how many rows are in the filtered data and then offset the manual range by that amount but I don't know how to exactly implement it.

Thanks in advance.

shift rows ex.xls


I would like to know if it is possible to make drop downs copy into new rows added automatically. I have a spreadsheet that will be used to track abnormal pap smears at a women's health clinic. I want to use drop down lists for many of the columns to limit choices people can make when entering data. I would like a new row to be added with all the drop downs whenever a new patient is added to the list. I have tried using format as table, but the drop downs are not copied when a new row is added. Is this possible?

I have attached the first two rows (headers and drop downs) so you can see what I am doing.

Thanks in advance,
JimAbnormal Paps.xlsx

Thanks to everyone that has been helping me with this project so far

From the sample file, I am using the data on (start) worksheet.

(Sort and format sheet)
This one is way over my head. After new data is added to the sheet via another UserForm, I want to sort the list by name and have alternating backgrounds based on grouped unique names.


I have a table that until recently was doing what was expected. Meaning, the above formulas, data validation lists and conditional formating was being applied to the next row of the table when I Tab down from the last cell. Recently I moved some columns as well as added and deleted some. Now some of the formatting is not being transferred down. The data validation lists as well as the formulas are however. The stangest thing to me is that certain formatting is being transferred down while others are not. Meaning Cells A37 thru K37 for example may have three different types of conditional formatting attributed to them. In the newly added row that same range may only 2! Even after I reformat the offending cells in the new row, the formatting is still not carried down to a new row! Any insight?

Hi All,

These forums have been great for me however I can't seem to find a solution to my problem.

I have 3 salesman, each with their own proposal log.

Upon clicking a button (in excel) to create a proposal (using a merge from named ranges in excel to bookmarks in a word template), I want the macro to first open up the salesman's relevant proposal log and copy certain named ranges into a new row at the bottom of the log table.

I get no errors when running the code and the correct proposal log is opened (as well as the merge to the word document), however the range I want to copy and paste into the proposal log does not occur and I can't work out why.

Here is the code:

    Dim wk As String 
    On Error Goto Notopen 
    wk = Workbooks(Book).Name 
    Workbookopen = True 
    Exit Function 
    Workbookopen = False 
End Function 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

    Dim pappWord As Object 
    Dim docWord As Object 
    Dim wb As Excel.Workbook 
    Dim Propwb As Excel.Workbook 
    Dim xlName As Excel.Name 
    Dim TodayDate As String 
    Dim Path As String 
    Dim YesOrNoAnswerToMessageBox As String 
    Dim QuestionToMessageBox As String 
    Dim Ph As String 
    Dim Sm As String 
    QuestionToMessageBox = "Are you sure you wish to create proposal?" 
    YesOrNoAnswerToMessageBox = MsgBox(QuestionToMessageBox, vbYesNo, "Create Proposal or Not") 
    If YesOrNoAnswerToMessageBox = vbNo Then 
        Ph = Workbooks("Estimate Sheet7").Path 
        Sm = [salesman] 
        On Error Resume Next 
        If [salesman] = "AP" Then 
            If Not Workbookopen("AP Proposal Log.xlsm") Then 
                Workbooks.Open Filename:=Ph & "AP Proposal Log.xlsm", UpdateLinks:=0 
            End If 
        ElseIf [salesman] = "MB" Then 
            If Not Workbookopen("MB Proposal Log.xlsm") Then 
                Workbooks.Open Filename:=Ph & "MB Proposal Log.xlsm", UpdateLinks:=0 
            End If 
        ElseIf [salesman] = "JH" Then 
            If Not Workbookopen("JH Proposal Log.xlsm") Then 
                Workbooks.Open Filename:=Ph & "JH Proposal Log.xlsm", UpdateLinks:=0 
            End If 
        End If 
        Set Propwb = Workbooks(Sm & " Proposal Log.xlsm") 
        Windows("Estimate Sheet7").Activate 
        Sheets("Calc Sheet").Select 
        Sheets("Proposal Log").Select 
        ActiveCell.Offset(1, 0).Activate 
        Sheets("Proposal Log").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
        :=False, Transpose:=False 
        Application.CutCopyMode = False 
    End If 
    Set wb = ActiveWorkbook 
    TodayDate = Format(Date, "mmmm d, yyyy") 
    Path = wb.Path & "DROSS PRESS PROPOSAL - bookmark attempts 7" 
    On Error Goto ErrorHandler 
     'Create a new Word Session
    Set pappWord = CreateObject("Word.Application") 
    On Error Goto ErrorHandler 
     'Open document in word
    Set docWord = pappWord.Documents.Add(Path) 
     'Loop through names in the activeworkbook
    For Each xlName In wb.Names 
         'if xlName's name is existing in document then put the value in place of the bookmark
        If docWord.Bookmarks.Exists(xlName.Name) Then 
            docWord.Bookmarks(xlName.Name).Range.Text = Range(xlName.Value) 
        End If 
    Next xlName 
     'Activate word and display document
    With pappWord 
        .Visible = True 
        .ActiveWindow.WindowState = 0 
    End With 
     'Release the Word object to save memory and exit macro
    Set pappWord = Nothing 
    Exit Sub 
     'Error Handling routine
    If Err Then 
        MsgBox "Error No: " & Err.Number & "; There is a problem" 
        If Not pappWord Is Nothing Then 
            pappWord.Quit False 
        End If 
        Resume ErrorExit 
    End If 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Any help would be greatly appreciated.



I am working on a spreadhseet with multiple tables present on the sheet. Each table has various formatting, merged cells, formulas, and defined lists. I need to have the table add a new row below the last including cell formatting, formulas, defined lists, so I can just keep going through and do data entry. The code adds a row at the end so I don't run into the table below the present one, by monitoring how far away it is from the "Type" cell tag in column A. The code below is a compilation from viewing other threads, but it just does a copy and paste, including the data that was input so I'm looking at a duplicate row.

How can I get ito to clear values in the new row? I can't seem to get it to paste xlPasteFormat and xlPasteFormulas

Is the new row in fact being added below the last? I think it's up one after the macro had run through.

Thank you,

Private Sub Worksheet_Change(ByVal Target As Range) 
    r = Target.Row 
    c = Target.Column 
    If c  1 Then Exit Sub 
    Application.EnableEvents = False 
    NextLineValue = Cells(r + 3, c) 
    If NextLineValue = "Type" Then 
        ActiveCell.Offset(1, 0).EntireRow.Copy 
        ActiveCell.Offset(0, 0).EntireRow.PasteSpecial xlPasteAll 
        Application.CutCopyMode = False 
    End If 
    Application.EnableEvents = True 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

Hi everyone,

I am not sure if what I want to do is possible. I have a spreadsheet with 2 worksheets, ie:

- Parts Details: which contains a table of data
- Pivot Table: which is the pivot table based on data from the 'Parts Details' worksheet + additional details.

In the 'Pivot Table' worksheet, the pivot table is contained from columns A to F, then all data beyond column F (i.e. columns G, H and I in this case) are static, ie data which have been entered manually.

Rows are added to the 'Parts Details' worksheet on a weekly basis, the fact of refreshing the pivot table every week makes the pivot table "grows". This is fine however the cells from the columns which are not part of the pivot table (i.e. columns G, H and I) do not shift up or down according to their Product ID in column B.


I have provided an example in the attached spreadsheet. Basically copy cell range A2 to G7 from the 'Additional Data' worksheet, then paste the it to cell A21 of the 'Parts Details' worksheet (this is to simulate adding rows to the worksheet). Go to the 'Pivot Table' worksheet, right click on the pivot table and select REFRESH.

You can notice that the pivot table is properly updated, however I would have like the data which are not part of the pivot table (i.e. columns G, H and I) to remain associated to their Product ID present in column B. In this example, we can notice that cells G6, H6 and I6 remain in their original position instead of being shifted down respectively to position G9, H9 and I9.

Would anyone know what kind of macro could allow me to achieve the above?

I think the best way would be to (refer to 'Pivot Table 1' worksheet):

1) Copy the data from column B (i.e. Product ID field of the pivot table) to a static column such a column J (note that I could do this manually)
2) Add the data to the 'Parts Details' worksheet (this would be done automatically however you can use the data from the 'Additional Data' worksheet for this test)
3) Refresh the pivot table which adds rows (note that I'll do this manually)
4) Use a macro to:
a) Look for the value from Cell J3 in column B
b) Determine the row at which the value is found in column B
c) Shift cells G3, H3, I3 and J3 to the row determined in previous step
d) Carry on searching for the next value in column B (i.e. cell J4)
e) And go back to step a) above...
The trick would be not to overwrite the data in step c).

I have tried to explain what I would like to achieve, however I am not sure if that makes sense and if it is possible at all. Hopefully it will to someone who's reading this!


Hi, I have been struggling with this problem for many days now and would really appreciate some help.

I have programmed before, but never any VBA stuff, so I'm teaching myself as I go along.

I have a worksheet with contents in two columns.
Column A - I have ID numbers
Column B - I have the number of days

What needs to get done
For every ID number, I need to have inserted x number of rows, where x is the corresponding number for the ID number from column B.

A1 has ID Number 001 and B1 has 2
A2 has ID Number 002 and B2 has 3
A3 has ID Number 003 and B3 has 2

When I execute the macro:

A1 needs to have 001, B1 says 1 with a new empty row below that AND
A3 needs to say 002, B3 says 3 with 2 empty rows below that AND
A6 needs to say 003, B6 says 4 with 1 empty row below that
... and so on

The numbers in column be are NOT sequential or follow any pattern.

I have attached the sample file, along with a macro that I created. However, it works only for the first two rows, after that it keeps pushing down the new rows without getting to the "header" row.

I hope I have explained it sufficiently well. Hopefully someone will be able to help me.

Edit: I should add that the way I tackled the problem was to find out how many rows we have, and store the number of days in an array.

I'd then do a loop that loops based on the number of rows I have, and in that one, nest another loop that would insert new rows based on each member of the array.

The obvoius problem is after inserting the first set of rows, being able to position myself so as to insert the 2nd set of rows (and third, and so on) at the correct points, and not just at the top.

This is the part that is driving me crazy, as it's relative based on how many previous rows have been inserted.

Here's my situation: I have a worksheet on which users will enter data one row at a time, in columns A-K. When the user starts to enter data in a new row #, that is, when they make any column in the next, unused row have non-blank value, I'd like the sheet to update the borders of the row for columns A-K. I want the Range from A1 to K# to have full borders, so that the whole data set is outlined and easier to read. For a bonus, I'd like the formulas from the previous H, I, and J cells copied down into H#, I#, and J#, adjusted appropriately for their reference changes.

Normally, I would work around the edges of such a VB problem by recording the actions manually and then modifying that code as I learned more. But I'm not sure if what I've done is the right way to start that process. I think that if I use the CurrentRegion property, and the Worksheet_Change event, I'll be well on my way.

Here's some skeleton code that's on the way to being what I want:

Dim rng As Object
Dim Act_Cell As String
Dim Act_Row As Integer

Private Sub Worksheet_Change(ByVal Target As Range)
    Act_Cell = ActiveCell.Address
    Act_Row = ActiveCell.Row
    Application.ScreenUpdating = False
    Application.ScreenUpdating = True
    Range("H" & Act_Row - 1 & ":J" & Act_Row).FillDown
End Sub

Sub SetBorders()

    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

End Sub
When I make a change, though, the screen is updating for 10-20 seconds, like it's applying the formulas to many many cells. I have to press CTRL+Break to halt it. Where's the long loop coming from?

Update: I never did resolve this loop issue, though I believe that the Worksheet_Change event got called everytime formatting and the like were copied by my macro into a new row. Regardless, JB's comment below gave me the functionality I needed w/ no fuss or coding needed. Thanks JB!

I have a named range in my spreadsheet that refers to a row in the spreadsheet (say row 400). I want to run a macro that moves that named range down to the row below it each time I run it. So when I run it "MyName" will refer to row 401 instead of 400.

At the moment I use a simple macro with one line:


that deletes the row and then I recreate it manually one row down.

Any help much appreciated.


I have the sum as function in cell 1918 =SUM(C43:C1917). But many times I update the source data and I d like tthis formula to go down as new rows are added. I think I must use offset but I m not sure


Hi all,

Hope you can help?

I have a vLookup setup on column B and have my worksheet setup so a new row is automatically inserted when the last selection is made in column H.

The issue is that the vLookup formula isn't copied down to the new row when it is inserted.

What is the best way of sorting this out? Am I right in thinking that the vLookup should be specified in the sheet code to work efficiently? Or am I missing a trick?
If my hunch is right... How do I do this?

Many thanks

I've created a spreadsheet that tracks problems using an assigned problem number. Attached is the spreadsheet.

I need assistance in inserting a new row and incrementing the sequential number after pressing the "Get/Assign New NCR Number" button. I am successful at getting a new row added, but am not able to increment the number. In addition, I would also like to have the table locked so that no deleting or amending the sequential number is allowed.

Thank you,

I'm trying to copy an offset formula down about 1000 rows.

If the formula is =offset($B$5,1,0)

How can I copy down to read =offset($B$5,2,0)

then =offset($B$5,3,0)

without manually having to change the row # being offset?

Thanks for your help.

Assume I put the following formula in cell A1=SUM(B2:B15).
Fine for the current state.
But the number of rows/cells affected in this formula could change later.

If, for example, a user adds one or more rows before lets say row 5 then the upper bound remains currently stable. All amount values from B2 up to B15 were added.

But I want all values in the column to be added regardsless if new rows were added or existing ones removed. So I would like to see B2 as the "magic"start cell and B15 as the "magic" end cell. When a new row in between is inserted then the SUM() forumula should AUTOMATICALLY be updated to


For deletion of rows vice versa.

How can I achieve this?


I am trying to insert rows to a spreadsheet, but I want the formula of the previous row to automatically be inserted into the new row. I did a little bit of searching on this forum and someone mentioned adding a change event or something. I am unfamiliar with how to do this.

Is there an add-in that does this for you?

Thanks a million

PS: I just spotted this thread so I'm trying this first:
PSS: I am new to the forum and I'm loving it already ... you all seem very knowledgable

Hi there

I am so stuck on this, i need to when i press a button, for all th
text i have entered into my text boxes which is customer data to b
entered into the table of data nd a new row added for the next data t
be entered into, any ideas anyone, My file is attached???


from c

Message posted from

I have fought with this for 2 days and I am trying to have a worksheet cell update the date and time if the cell it is referencing (B3 see below)

Here is the formula I am using however it updates every time a new row is added to the worksheet. So the Date/Time stamp on each row is always updated to NOW() everytime.

=IF(ISNA(B3),"0/0/00 00:00",NOW())

I would like to have a Date/Time stamp stay as is once that row has been added. Is there anyway to stop the field from updating once the date and time have been set?



I have a .csv file that stores the results of a license count SQL query. This query runs on the hour during office hours. Depending on license usage, the data can range from 1 new row added to 15 new rows added per hour. Each row contains an indentifier, an integer, and the system time from the database.

I then have to manually enter these figures into an excell spreadsheet in order to add totals. I there a way to automate this function? The identifers are not unique, they can be repeated on the hour.

I have attached to two files as it would be easier to open and look at what I'm trying to do. vm_LicensesLog will be the destination file for the look up data.

Thanks in advance.


When I insert a new row using my macro, it work fine, however, when it inserts, one of my pieces of information doesn't move down (b/c I coded it to be placed in that specfic row). How do I get that info to stay in that assigned row, just moved down one row?

My code for inserting the row is:

Range("A" & Rows.Count).End(xlUp).Select
z = ActiveCell.Row
Cells(z + 1, 1).Select
ActiveCell.Value = SSRF
ActiveCell.Offset(0, 1).Value = SSRname

and my code that places in the info after that, further down my sheet is:

Sheets(mActiveSheet).Range("C52:P52") = (Sheets("Workdays").Range("F13")) * 8

So instead of the Range("C52:P52"), I need something that will move it down a row when that new row is entered. Any ideas???

I have two worksheets with ranges, one is 452 rows by 11 columns and the other is 152 rows by 28 columns. The ranges are not only filled with data but make heavy usage of conditional formatting.

Each day, I need to shift all of the rows down one row. Doing a copy/paste of the entire range less the first row blows up on memory usage.

I wrote the following VBA routine to handle the shift one row at a time ... this one handles the 452x11. It does the job but takes 20 seconds on the 452x11 range and same routine takes 40 seconds on the 152x28 range.

  Dim iRangeRowX As
  Dim iRangeRowsInRange As Integer
  Dim iRangeBeginsRow As Integer
  Dim iRangeEndsRow As Integer
  Dim rRange As Range
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Set rRange = Worksheets("BreadthModels").Range("BreadthModelTable")
  With rRange
    iRangeRowsInRange = .Rows.Count  ' row count for this range
    iRangeBeginsRow = .Row     ' first row for this range
    iRangeEndsRow = (iRangeBeginsRow + iRangeRowsInRange) - 1
    ' columns are hard coded
    For iRangeRowX = (iRangeBeginsRow + 2) To (iRangeEndsRow - 1) Step 1
      Range("E" & iRangeRowX & ":P" & iRangeRowX).Select
      Application.CutCopyMode = False
      Range("E" & iRangeRowX - 1 & ":P" & iRangeRowX - 1).Select
      DoEvents  'allow break
  End With
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
Is there anything which can be done to speed execution? Thank you.


I appreciate any help on this matter.

My code (below) will insert a new cell but what I need is for it to insert a whole new row.

Cells.Find(What:="licenced offices", After:=ActiveCell).Activate 
Selection.Insert Shift:=xlDown 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Thank you

Hello All,

Ok, I am just getting into the macro aspect of excel, so please be patient with me. I basically am trying to create a macro that creates a new row of data under existing data in a table (not really a table but just a range as of now). Here are my two main criteria:

1) I have some cells that have data validation, some cells with formulas, and some cells with just text (really symbols) that I want copied down from the row above into the newly created row. I need all cells (other than the rows with symbols) to show as blank, however upon creating the new row.
2) I want the row to always be created after the last row of data.

I have tried using the macro recorder to try doing this as well as researched everywhere online but I am not experienced enough in VBA to get the syntax down quite right for what I am trying to do.

I have attached the workbook for your reference. To put it more clearly:

- I want to create a Macro that adds a row after the last row of data in the table. Currently this would be after row 22, however, after adding another row, I would want it added after row 23 and so forth and so on.
- I would like it to copy the formulas and data validation in cells C22, D22, E22, and I22, but not I don't want any selections made for the cells with data validations (D22:E22). As long as those cells are clear, cell C22 should be empty based on the vlookup formula in that cell.
- I would like it to copy the contents from cells F22 & H22 as is in the new row.

Thank you so much for any help you can provide!!

Hi guys,

I've cobbled together a macro to extract data from several worksheets and paste into a new worksheet based on AutoFilter criteria. Works pretty darn well, except for one major problem: If a worksheet has no records matching the AutoFilter criteria, all the records in that worksheet are selected and pasted. Can anyone help me fix that. Here's the macro:

     ' macro to select filtered data and paste to new sheet
     ' Macro by Steve Terek on 20 Nov 2009
    Dim i As Integer 
    Dim rngData As Range 
    Application.ScreenUpdating = False 
    Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "AEF" 
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _ 
    SkipBlanks:=False, Transpose:=False 
    For i = 2 To 10 
        Selection.AutoFilter Field:=7, Criteria1:="AEF" 
        Set rngData = ActiveSheet.Range("A1").CurrentRegion 
        Set rngData = rngData.Resize(rngData.Rows.Count - 2) 
         'Move new range down to Start at the fisrt data row.
        Set rngData = rngData.Offset(2, 0) 
        Range("A65536").End(xlUp).Offset(1, 0).Select 
    Next i 
    Application.CutCopyMode = False 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

Hi I have a grid matrix that i am entering values into. I need to be able to insert rows or cells at the end of grid when it is almost full. At the moment the values just overlap into the next grid. I also have the code set to a range of values so when the new row/cell is inserted, this must reflect in the new range. The workbook is at this url to see:

My existing code is below:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column = 2 Then
Sheets("Activities").Columns("f:u").Font.ColorIndex = 2
Select Case Target.Offset(, -1).Value
Case 1, 2
lr = Range("f" & Rows.Count).End(xlUp).Row + 1
Cells(lr, 6).Resize(, 3).Value = Array(Target.Offset(, -1).Value, Target.Value, Target.Offset(, 2).Value)
lr = Range("f" & Rows.Count).End(xlUp).Row
Range("F2:H" & lr).Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
lr = Range("f" & Rows.Count).End(xlUp).Row
ii = 4
For i = 2 To lr
Worksheets("Summary").Range("c" & ii).Value = Worksheets("Activities").Range("g" & i).Value
Worksheets("Summary").Range("c" & ii).Font.Bold = True
Worksheets("Summary").Range("c" & ii).Font.Color = vbRed
ii = ii + 1
Case 3, 4
lr = Range("m" & Rows.Count).End(xlUp).Row + 1
Cells(lr, 13).Resize(, 3).Value = Array(Target.Offset(, -1).Value, Target.Value, Target.Offset(, 2).Value)
lr = Range("m" & Rows.Count).End(xlUp).Row
Range("m2:o" & lr).Sort Key1:=Range("o2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
lr = Range("m" & Rows.Count).End(xlUp).Row
ii = 4
For i = 2 To lr
Worksheets("Summary").Range("d" & ii).Value = Worksheets("Activities").Range("n" & i).Value
ii = ii + 1
Case 5, 6
lr = Range("p" & Rows.Count).End(xlUp).Row + 1
Cells(lr, 16).Resize(, 3).Value = Array(Target.Offset(, -1).Value, Target.Value, Target.Offset(, 2).Value)
lr = Range("p" & Rows.Count).End(xlUp).Row
Range("p2:r" & lr).Sort Key1:=Range("r2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
lr = Range("p" & Rows.Count).End(xlUp).Row
ii = 26
For i = 2 To lr
Worksheets("Summary").Range("c" & ii).Value = Worksheets("Activities").Range("q" & i).Value
ii = ii + 1
Case 7, 8
lr = Range("s" & Rows.Count).End(xlUp).Row + 1
Cells(lr, 19).Resize(, 3).Value = Array(Target.Offset(, -1).Value, Target.Value, Target.Offset(, 2).Value)
lr = Range("s" & Rows.Count).End(xlUp).Row
Range("s2:u" & lr).Sort Key1:=Range("u2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
lr = Range("s" & Rows.Count).End(xlUp).Row
ii = 26
For i = 2 To lr
Worksheets("Summary").Range("d" & ii).Value = Worksheets("Activities").Range("t" & i).Value
ii = ii + 1
End Select
End If
If Target.Column = 5 Then
If Target.Value = "Close" Then
With Sheets("Summary").Range("c4:d51")
Set c = .Find(Target.Offset(, -3).Value, , , xlWhole)
If Not c Is Nothing Then
Select Case c.Column
Case 3
cl = 3
Case Else
cl = 4
End Select
Select Case c.Row
Case Is < 18
rw = 17
Case Else
rw = 32
End Select
Sheets("Summary").Cells(rw, cl).Insert Shift:=xlDown
c.Delete Shift:=xlUp
End If
End With
With Sheets("Activities").Columns("f:u")
Set c = .Find(Target.Offset(, -3).Value, , , xlWhole)
If Not c Is Nothing Then
c.Offset(, -1).Resize(, 3).Delete Shift:=xlUp
End If
End With

End If
End If
End Sub