This one works great. I just want to know how to add the data to an existing
sheet instead of creating a new one everytime I run it. thanks
Sub testme()
Dim CurWks As Worksheet
Dim RptWks As Worksheet
Dim iRow As Long
Dim oRow As Long
Dim FirstRow As Long
Dim LastRow As Long
Set CurWks = Worksheets("Sheet1")
Set RptWks = Worksheets.Add
With CurWks
FirstRow = 2
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
oRow = -1
For iRow = FirstRow To LastRow
If .Cells(iRow, "A").Value = .Cells(iRow - 1, "A").Value _
And .Cells(iRow, "B").Value = .Cells(iRow - 1, "B").Value Then
'same group, do nothing special
Else
'different group, do headers
oRow = oRow + 2
RptWks.Cells(oRow, "A").Value _
= "Owner: " & .Cells(iRow, "A").Value
oRow = oRow + 1
RptWks.Cells(oRow, "A").Value _
= "Beneficiary: " & .Cells(iRow, "A").Value
oRow = oRow + 2
RptWks.Cells(oRow, "A").Value = "Policy#"
RptWks.Cells(oRow, "B").Value = "Company"
RptWks.Cells(oRow, "C").Value = "Effective Date"
RptWks.Cells(oRow, "D").Value = "Face Amount"
RptWks.Cells(oRow, "E").Value = "Cash Value"
RptWks.Cells(oRow, "F").Value = "Surrender Value"
RptWks.Cells(oRow, "G").Value = "Annual Premium"
RptWks.Cells(oRow, "H").Value = "Policy Type"
End If
'do the policy stuff
oRow = oRow + 1
RptWks.Cells(oRow, "A").Value = "'" & .Cells(iRow, "C").Value
RptWks.Cells(oRow, "B").Value = "'" & .Cells(iRow, "D").Value
RptWks.Cells(oRow, "C").Value = "'" & .Cells(iRow, "E").Value
RptWks.Cells(oRow, "D").Value = "'" & .Cells(iRow, "F").Value
RptWks.Cells(oRow, "E").Value = "'" & .Cells(iRow, "G").Value
RptWks.Cells(oRow, "F").Value = "'" & .Cells(iRow, "H").Value
RptWks.Cells(oRow, "G").Value = "'" & .Cells(iRow, "I").Value
RptWks.Cells(oRow, "H").Value = "'" & .Cells(iRow, "J").Value
Next iRow
End With
End Sub
ielmrani wrote:
Thanks Dave,
I only give you a sample of what I was trying to do. Now I am trying to
apply your code to a real sheet. I revised the code but it's not working.
Anytime I run the code it creates a new sheet, can it populate the data in an
existing sheet?
I tried to add new columns but they're not appearing in the sheet when I run
the code.
Please bear with me I am not an expert in excel, I am trying though. Thanks
so much.
Here is what I did so far:
Sub testme()
Dim CurWks As Worksheet
Dim RptWks As Worksheet
Dim iRow As Long
Dim oRow As Long
Dim FirstRow As Long
Dim LastRow As Long
Set CurWks = Worksheets("Sheet1")
Set RptWks = Worksheets.Add
With CurWks
FirstRow = 2
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
oRow = -1
For iRow = FirstRow To LastRow
If .Cells(iRow, "A").Value = .Cells(iRow - 1, "A").Value _
And .Cells(iRow, "B").Value = .Cells(iRow - 1, "B").Value Then
'same group, do nothing special
Else
'different group, do headers
oRow = oRow + 2
RptWks.Cells(oRow, "A").Value _
= "Owner: " & .Cells(iRow, "A").Value
oRow = oRow + 1
RptWks.Cells(oRow, "A").Value _
= "Beneficiary: " & .Cells(iRow, "A").Value
oRow = oRow + 2
RptWks.Cells(oRow, "A").Value = "Policy#"
RptWks.Cells(oRow, "B").Value = "Company"
RptWks.Cells(oRow, "C").Value = "Effective Date"
RptWks.Cells(oRow, "D").Value = "Face Amount"
RptWks.Cells(oRow, "E").Value = "Cash Value"
RptWks.Cells(oRow, "C").Value = "Surrender Value"
RptWks.Cells(oRow, "C").Value = "Annual Premium"
RptWks.Cells(oRow, "C").Value = "Policy Type"
End If
'do the policy stuff
oRow = oRow + 1
RptWks.Cells(oRow, "A").Value = "'" & .Cells(iRow, "C").Value
RptWks.Cells(oRow, "B").Value = "'" & .Cells(iRow, "D").Value
RptWks.Cells(oRow, "C").Value = "'" & .Cells(iRow, "E").Value
RptWks.Cells(oRow, "D").Value = "'" & .Cells(iRow, "F").Value
RptWks.Cells(oRow, "E").Value = "'" & .Cells(iRow, "G").Value
RptWks.Cells(oRow, "F").Value = "'" & .Cells(iRow, "H").Value
RptWks.Cells(oRow, "G").Value = "'" & .Cells(iRow, "I").Value
RptWks.Cells(oRow, "H").Value = "'" & .Cells(iRow, "J").Value
Next iRow
End With
End Sub
This actually belongs in a General module--not behind a worksheet.
[quoted text clipped - 6 lines]
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...excel/200806/1
--
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...excel/200806/1