title: Macro to insert blank cells below if value >1 and copy/paste values from cell above
body: <p>This site already has something similar:  <a href="https://stackoverflow.com/questions/19504741/copy-and-insert-rows-based-off-of-values-in-a-column">Copy and insert rows based off of values in a column</a></p>
  
  <p>but the code doesn't take me quite where I need to go, and I haven't been able to tweak it to make it work for me.</p>
  
  <p>My user has a worksheet with 4 columns, A-D.  Column A contains specific contract numbers, column B is blank, column C has part numbers, and column D has the entire range of contract numbers.  My user wants to count the number of times the entire range contract numbers has duplicates so I entered the formula <code>=countif($D$2:$D$100000,A2)</code> in cell E2 and copied down, giving me the number of times the specific contract in column A appears in column D.  The numbers range from 1 to 11 in this workbook but the number may be higher in other workbooks this method will be used in.  </p>
  
  <p>The next thing I need to do is to enter blank cells below all values in column E that are greater than 1, very much like the example in the previously asked question.  I then also need to copy in the same row and insert copied cells exactly to match in the same row in column A.  Example:  Cell E21 has the number 5 so I need to shift cells in column E only so that there are 4 blanks cells directly below it.  In column A, I need to copy cell A21 and insert copied cells in four rows directly below.</p>
  
  <p>Just trying to get the blank cells to insert has been a trial, using the code as given in the previous question.</p>
  
  <pre><code>    Dim sh As Worksheet
      Dim lo As ListObject
      Dim rColumn As Range
      Dim i As Long
      Dim rws As Long
  
      Set sh = ActiveSheet
      Set lo = sh.ListObjects("Count")
  
      Set rColumn = lo.ListColumns("Count").DataBodyRange
      vTable = rColumn.Value
  
      For i = rColumn.Rows.Count To 1 Step -1
          If rColumn.Cells(i, 1) &gt; 1 Then
              rws = rColumn.Cells(i, 1) - 1
              With rColumn.Rows(i)
                  .Offset(1, 0).Resize(rws, 1).Cells.Insert
                  .EntireRow.Copy .Offset(1, 0).Resize(rws, 1).Cells
                  .Offset(1, 0).Resize(rws, 1).EntireRow.Font.Strikethrough = True
              End With
          End If
      Next
  </code></pre>
  
  <p>I would be very grateful for any help as I have been fighting with this monster for a week.</p>