Prompt for # of new rows, copy formulas and conditional formatting

**tecsbrain** · 10-24-2014, 02:20 PM

Hi EF,

Per the subject, I have a workbook where people will continuously enter data at the rate of about 100 rows per day. The first and last columns (A and K) contain formulas and/or conditional formatting.

I found a macro that purports to do 80% of what I want:

Sub InsertRowsAndFillFormulas_caller()
  '-- this macro shows on Tools, Macro..., Macros (Alt+F8) dialog 
  Call InsertRowsAndFillFormulas
End Sub
 
Sub InsertRowsAndFillFormulas(Optional vRows As Long = 0)
' Documented:  http://www.mvps.org/dmcritchie/excel/insrtrow.htm
' Re: Insert Rows --   1997/09/24 Mark Hill <[email protected]>
   ' row selection based on active cell -- rev. 2000-09-02 David McRitchie
   Dim x as long 
   ActiveCell.EntireRow.Select  'So you do not have to preselect entire row
   If vRows = 0 Then
    vRows = Application.InputBox(prompt:= _
      "How many rows do you want to add?", Title:="Add Rows", _
      Default:=1, Type:=1) 'Default for 1 row, type 1 is number
    If vRows = False Then Exit Sub
   End If

   'if you just want to add cells and not entire rows
   'then delete ".EntireRow" in the following line

   'rev. 2001-01-17 Gary L. Brown, programming, Grouped sheets
   Dim sht As Worksheet, shts() As String, i As Long
   ReDim shts(1 To Worksheets.Application.ActiveWorkbook. _
       Windows(1).SelectedSheets.Count)
   i = 0
   For Each sht In _
       Application.ActiveWorkbook.Windows(1).SelectedSheets
    Sheets(sht.Name).Select
    i = i + 1
    shts(i) = sht.Name

    x = Sheets(sht.name).UsedRange.Rows.Count 'lastcell fixup

    Selection.Resize(rowsize:=2).Rows(2).EntireRow. _
     Resize(rowsize:=vRows).Insert Shift:=xlDown

    Selection.AutoFill Selection.Resize( _
     rowsize:=vRows + 1), xlFillDefault

    On Error Resume Next    'to handle no constants in range -- John McKee 2000/02/01
    ' to remove the non-formulas -- 1998/03/11 Bill Manville
    Selection.Offset(1).Resize(vRows).EntireRow. _
     SpecialCells(xlConstants).ClearContents
   Next sht
   Worksheets(shts).Select
End Sub

But I installed and ran it and it crashes my worksheet ("Not enough system resources to display completely"). This is being done on a pretty high-end computer (16GB RAM, i7 processor) so I doubt it couldn't handle such a task.

Also, this doesn't handle my conditional formatting requirement.

I've attached the worksheet in question (it's a binary) if anyone wants to take a stab at it or a different approach.

**jaslake** · 10-26-2014, 04:19 PM

Hi tecsbrain

Try replacing your Module 2 Code with this. CTRL + i will fire the Code

Public ws As Worksheet
Option Explicit

Sub Insert_Rows()
  Dim Rng As Range, cel As Range
  Dim LR As Long, vRows As Long

  If vRows = 0 Then
    vRows = Application.InputBox(prompt:= _
                                 "How many rows do you want to add?", Title:="Add Rows", _
                                 Default:=1, Type:=1)  'Default for 1 row, type 1 is number
    If vRows = False Then Exit Sub
  End If

  Set ws = Sheets("Entries")
  Application.EnableEvents = False
  With ws
    LR = .Range("A" & .Rows.Count).End(xlUp).Row
    .Range("A" & LR).AutoFill Destination:=.Range("A" & LR & ":A" & LR + vRows), Type:=xlFillDefault
    .Range("K" & LR).AutoFill Destination:=.Range("K" & LR & ":K" & LR + vRows), Type:=xlFillDefault
  End With
  Call ResetFormatting
  Application.EnableEvents = True
End Sub



Sub ResetFormatting()
  Dim LR As Long
  ' ----------------------------------------------------------------------------------------
  ' Written by..: Julius Getz Mørk; Modified by jaslake for tecsbrain 10/26/2014
  ' Purpose.....: If conditional formatting ranges are broken it might cause a huge increase
  '               in duplicated formatting rules that in turn will significantly slow down
  '               the spreadsheet.
  '               This macro is designed to reset all formatting rules to default.
  ' ----------------------------------------------------------------------------------------
  Set ws = Sheets("Entries")
  With ws
    LR = .Range("A" & .Rows.Count).End(xlUp).Row
    On Error GoTo ErrHandler

    ' Disable Events
    Application.EnableEvents = False

    ' Delete all conditional formatting rules in sheet
    .Cells.FormatConditions.Delete

    ' CREATE ALL THE CONDITIONAL FORMATTING RULES:
    With .Cells(1, 1).FormatConditions.Add(xlCellValue, xlLess, "=0")
      .Interior.Color = RGB(218, 150, 148)
    End With

    With .Cells(1, 1).FormatConditions.Add(xlCellValue, xlGreater, "=.00277777777778")
      .Interior.Color = RGB(141, 180, 226)
    End With

    ' Modify the "Applies To" ranges
    .Cells.FormatConditions(1).ModifyAppliesToRange .Range("K2:K" & LR)
    .Cells.FormatConditions(2).ModifyAppliesToRange .Range("K2:K" & LR)
  End With
ErrHandler:
  Application.EnableEvents = True
End Sub

**tecsbrain** · 11-06-2014, 06:48 AM

Thanks a bunch jaslake. Only one issue remains, and it's more an issue of Excel behavior than the macro I think, and something I forgot to mention. Because I am entering about 150 daily records under the same date, I need this code to copy the same date all the way down. When I ran it, it filled the date incrementing by one day all the way down for the number of rows I asked for.

Also, row B contains a formula that needs to be copied as well. Can you walk me through the code so I can learn how to modify it?

Possibly an even better solution than hacking it to copy the existing date in the starting cell would be for it to prompt for both a date and a number of cells...but that's just a preference.

Thanks a bunch -- why there isn't a "buy a drink" feature here, I don't understand.

**jaslake** · 11-06-2014, 12:08 PM

Hi tecsbrain

See if this does as required

Public ws As Worksheet
Option Explicit

Sub Insert_Rows()
  Dim Rng As Range, cel As Range
  Dim LR As Long, vRows As Long
  Dim myDate As String

  myDate = Application.InputBox(prompt:= _
                                "What Date (Format MM/DD/YYYY)?", Title:="Date???", _
                                Default:=Date, Type:=2)  'Default for 1 row, type 1 is number
  If myDate = "" Then Exit Sub

  If vRows = 0 Then
    vRows = Application.InputBox(prompt:= _
                                 "How many rows do you want to add?", Title:="Add Rows", _
                                 Default:=1, Type:=1)  'Default for 1 row, type 1 is number
    If vRows = False Then Exit Sub
  End If

  Set ws = Sheets("Entries")
  Application.EnableEvents = False
  With ws
    LR = .Range("A" & .Rows.Count).End(xlUp).Row
    .Range("A" & LR).AutoFill Destination:=.Range("A" & LR & ":A" & LR + vRows), Type:=xlFillDefault
    .Range("K" & LR).AutoFill Destination:=.Range("K" & LR & ":K" & LR + vRows), Type:=xlFillDefault
    .Range("B" & LR + 1).Resize(vRows, 1).Value = myDate
  End With
  Call ResetFormatting
  Application.EnableEvents = True
End Sub



Sub ResetFormatting()
  Dim LR As Long
  ' ----------------------------------------------------------------------------------------
  ' Written by..: Julius Getz Mørk; Modified by jaslake for tecsbrain 10/26/2014
  ' Purpose.....: If conditional formatting ranges are broken it might cause a huge increase
  '               in duplicated formatting rules that in turn will significantly slow down
  '               the spreadsheet.
  '               This macro is designed to reset all formatting rules to default.
  ' ----------------------------------------------------------------------------------------
  Set ws = Sheets("Entries")
  With ws
    LR = .Range("A" & .Rows.Count).End(xlUp).Row
    On Error GoTo ErrHandler

    ' Disable Events
    Application.EnableEvents = False

    ' Delete all conditional formatting rules in sheet
    .Cells.FormatConditions.Delete

    ' CREATE ALL THE CONDITIONAL FORMATTING RULES:
    With .Cells(1, 1).FormatConditions.Add(xlCellValue, xlLess, "=0")
      .Interior.Color = RGB(218, 150, 148)
    End With

    With .Cells(1, 1).FormatConditions.Add(xlCellValue, xlGreater, "=.00277777777778")
      .Interior.Color = RGB(141, 180, 226)
    End With

    ' Modify the "Applies To" ranges
    .Cells.FormatConditions(1).ModifyAppliesToRange .Range("K2:K" & LR)
    .Cells.FormatConditions(2).ModifyAppliesToRange .Range("K2:K" & LR)
  End With
ErrHandler:
  Application.EnableEvents = True
End Sub

**tecsbrain** · 11-06-2014, 01:01 PM

This almost works, except it still does the default Excel autofill (date increments by 1 each row) in column A and then # copies of the prompted date in column B. What I need (I wish I could understand enough VBA to make the change!) is for column A to contain the prompted # of rows of the entered date, and the formula in column B (which is =TEXT(DATE, "dddd")) copied down # times.

Thanks so much for your help!

**jaslake** · 11-06-2014, 03:40 PM

Hi tecsbrain

We're working with two different Files. My File Column A Formulas are

Formula:

=IF(DATE=0,"",TEXT(DATE, "dddd"))

Please attach your File that reflects this

the formula in column B (which is =TEXT(DATE, "dddd"))

**tecsbrain** · 11-06-2014, 04:23 PM

Oh, goodness! I must have forgotten to update the file. I'm making you do more work than necessary, my bad. I have to continue adding to this file every day and I guess at some point I made a usability change that I subsequently forgot about.

**jaslake** · 11-06-2014, 04:35 PM

Hi tecsbrain

Change the Column References as indicated

Public ws As Worksheet
Option Explicit

Sub Insert_Rows()
  Dim Rng As Range, cel As Range
  Dim LR As Long, vRows As Long
  Dim myDate As String

  myDate = Application.InputBox(prompt:= _
                                "What Date (Format MM/DD/YYYY)?", Title:="Date???", _
                                Default:=Date, Type:=2)  'Default for 1 row, type 1 is number
  If myDate = "" Then Exit Sub

  If vRows = 0 Then
    vRows = Application.InputBox(prompt:= _
                                 "How many rows do you want to add?", Title:="Add Rows", _
                                 Default:=1, Type:=1)  'Default for 1 row, type 1 is number
    If vRows = False Then Exit Sub
  End If

  Set ws = Sheets("Entries")
  Application.EnableEvents = False
  With ws
    LR = .Range("A" & .Rows.Count).End(xlUp).Row

    '##### Change Column Reference
    .Range("B" & LR).AutoFill Destination:=.Range("B" & LR & ":B" & LR + vRows), Type:=xlFillDefault
    .Range("K" & LR).AutoFill Destination:=.Range("K" & LR & ":K" & LR + vRows), Type:=xlFillDefault
    
    '##### Change Column Reference
    .Range("A" & LR + 1).Resize(vRows, 1).Value = myDate
  End With
  Call ResetFormatting
  Application.EnableEvents = True
End Sub



Sub ResetFormatting()
  Dim LR As Long
  ' ----------------------------------------------------------------------------------------
  ' Written by..: Julius Getz Mørk; Modified by jaslake for tecsbrain 10/26/2014
  ' Purpose.....: If conditional formatting ranges are broken it might cause a huge increase
  '               in duplicated formatting rules that in turn will significantly slow down
  '               the spreadsheet.
  '               This macro is designed to reset all formatting rules to default.
  ' ----------------------------------------------------------------------------------------
  Set ws = Sheets("Entries")
  With ws
    LR = .Range("A" & .Rows.Count).End(xlUp).Row
    On Error GoTo ErrHandler

    ' Disable Events
    Application.EnableEvents = False

    ' Delete all conditional formatting rules in sheet
    .Cells.FormatConditions.Delete

    ' CREATE ALL THE CONDITIONAL FORMATTING RULES:
    With .Cells(1, 1).FormatConditions.Add(xlCellValue, xlLess, "=0")
      .Interior.Color = RGB(218, 150, 148)
    End With

    With .Cells(1, 1).FormatConditions.Add(xlCellValue, xlGreater, "=.00277777777778")
      .Interior.Color = RGB(141, 180, 226)
    End With

    ' Modify the "Applies To" ranges
    .Cells.FormatConditions(1).ModifyAppliesToRange .Range("K2:K" & LR)
    .Cells.FormatConditions(2).ModifyAppliesToRange .Range("K2:K" & LR)
  End With
ErrHandler:
  Application.EnableEvents = True
End Sub

**tecsbrain** · 11-06-2014, 04:54 PM

You've made me a happy man. What can I do in return?

**jaslake** · 11-06-2014, 05:05 PM

If you're happy I'm happy.

If you're satisfied by any members response to your issue please use the star icon at the lower left of their post.

Prompt for # of new rows, copy formulas and conditional formatting

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Prompt for # of new rows, copy formulas and conditional formatting

Re: Prompt for # of new rows, copy formulas and conditional formatting

Re: Prompt for # of new rows, copy formulas and conditional formatting

Re: Prompt for # of new rows, copy formulas and conditional formatting

Re: Prompt for # of new rows, copy formulas and conditional formatting

Re: Prompt for # of new rows, copy formulas and conditional formatting

Re: Prompt for # of new rows, copy formulas and conditional formatting

Re: Prompt for # of new rows, copy formulas and conditional formatting

Re: Prompt for # of new rows, copy formulas and conditional formatting

Re: Prompt for # of new rows, copy formulas and conditional formatting

Thread Information

Users Browsing this Thread

Similar Threads

[SOLVED] Copy Conditional Formatting to other rows

Copy Conditional Formatting to other rows

Excel 2007 : Help inserting rows with correct formulas and conditional formatting

Excel 2007 : How to copy conditional formatting to all rows

Conditional Formatting Copy down Rows

Bookmarks

Bookmarks

Posting Permissions