On 5 jan, 15:49, S Davis wrote:
Hello,

Is there any way to insert a number of rows based on criteria?

Sample data:
A------------S---T---U-....
Bill---------(_)-(X)-(_)
Bob--------(_)-(_)-(_)
Joe---------(X)-(X)-(X)
Murph ....

(Where (_) denotes a blank cell)

Desired presentation:

Bill---------(_)-(X)-(_)
(blank row)
Bob--------(_)-(_)-(_)
Joe---------(X)-(X)-(X)
(blank row)
(blank row)
(blank row)
Murph ....

I have a list of names in column A, and a list of criteria names in S1
- Z1. For each name (ie. Bill), criteria is defined as met with any
marking in that column (ie. T1 = "X", or "o", or anything nonblank)

What I would like to do then is for every row, look at the range S-Z,
count the number of nonblank cells, and then insert that number of
nonblank rows directly underneath. Then move onto the next name until
the list is exhausted.

Ideally, though this may be asking too much, each row that is inserted
should then have the name of the criteria inserted into AA. So, for
instance, in the sample data above, if Bill has an X under column T,
and T1 reads "Car", the data should look like this:

A------------S---T---U-....AA
Bill---------(_)-(X)-(_)
---------------------------....Car
Bob....

Any help and a walkthrough of the code would be so much appreciated!
Thanks

Hi Bob,

In Excel2003 I have created the following:

Sub CreteriaLines()
' Declare contsants
Const cS As Integer = 19 ' for column S
Const cZ As Integer = 26 ' for column Z
Const cA As Integer = 1 ' for column A
Const cAA As Integer = 27 ' for column AA
' Declare variables
Dim lRs As Long ' for source row
Dim lRd As Long ' for destination row
Dim iCr As Integer ' for number for creteria
Dim rCr As Range ' for temporary range defenition
Dim iLp As Integer ' for looping column S to Z

' set source row and destination row
lRs = 1
lRd = 2

Do
Set rCr = Range(Cells(lRs, cS), Cells(lRs, cZ))
' count number of non blank cells
iCr = WorksheetFunction.CountA(rCr)
If iCr 0 Then
' insert empty lines
Range(Cells(lRd, cA), Cells(lRd + iCr - 1,
cA)).EntireRow.Insert _
shift:=xlDown
' loop columns S to Z
For iLp = cS To cZ
' if the cell if not empty
If Not IsEmpty(Cells(lRs, iLp)) Then
' copy the value to column AA of inserted line
Cells(lRd, cAA).Value = Cells(lRs, iLp)
' zet destination row 1 down
lRd = lRd + 1
End If
Next
End If
' reset source row and destination row
lRs = lRd
lRd = lRs + 1
Loop Until IsEmpty(Cells(lRs, cA))
End Sub


HTH,

Wouter