Selectively Moving Data to a Summary Sheet

[John Yab]

Would someone please help me with a macro? I have data on a sheet that I am
trying to selectively move to a summary sheet; below is an example:

Revenue Net


$1,296.00 $24.00

Revenue Net

$964.00 ($28.00)


Revenue Net
$416.00 ($40.00)
$416.00 ($40.00)
$416.00 ($40.00)

There are blocks of data on a sheet. Each block has a different number of
rows. Each block is seperated by one blank row.
In column P is the heading "Net" in each block. Under "Net" can be blanks or
a dollar amount or the blank between blocks of data or a new heading of "Net"
for a new block of data. I am trying to move the dollar amount to a summary
sheet. Sometimes there is more than one dollar amount in each block... I only
want the first instance of the dollar amount then I need to skip to the next
block and get the first instance of the dollar amount in that next block.
Sometimes there is no dollar amount and then I would have to skip to the next
block of data. When/if I find the dollar amount I need to copy and paste it
to the summary sheet and also copy and past the values in that same row from
column A (an ID) and column B (the end date). The value 2nd from the top of
the column B in that block of data is the "start" date. I need to capture the
start date too and move it to the summary sheet. In summary the macro would
grab 4 bits of data and move it to the summary sheet and then move on to the
next block of data a grab and move 4 bits of data from that block, etc.
I have been working hard with loops and cases and if's for a week and can't
quite get it so any help is very appreciated with big thanks.

 

[Don Guillett]

If desired, send your file to my address below. I will only look if:
1. You send a copy of this message on an inserted sheet
2. You give me the newsgroup and the subject line
3. You send a clear explanation of what you want
4. You send before/after examples and expected results.

 

[Don Guillett]

Sub GetDataSAS() 'insert a row at the top of the sheet
Application.ScreenUpdating = False

Dim r As Long
Dim lr As Long
Dim c As Range
r = 2
lr = Cells(Rows.Count, 1).End(xlUp).Row
With Worksheets(1).Range("p1" & lr)
Set c = .Find(What:="Net", After:=Range("p1"), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False)
If Not c Is Nothing Then
firstAddress = c.Address
Do
firstvaluerow = Evaluate("=MATCH(1,--(P" & c.Row + 1 & "" & lr &
"<>""""),0)") + c.Row
If LCase(Cells(firstvaluerow, "P")) <> "net" Then
With Sheets("summary")
..Cells(r, "e") = Cells(c.Row + 1, 1) 'symbol
..Cells(r, "f") = Cells(c.Row + 1, 2) 'startdate
..Cells(r, "g") = Cells(firstvaluerow, "B") 'enddate
..Cells(r, "h") = Cells(firstvaluerow, "P") 'endvalue
End With
r = r + 1
End If

Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
Application.ScreenUpdating = True
End Sub

 

[John Yab]

Hi Don,

Thank you so much for your help. Your code is fantastic. You do so much with
such few lines of code.

It turns out I am struggling a bit trying to get it to cycle through all the
sheets with “Ticker†in A1. I will keep trying but your help would be very
appreciated.

I made a mistake with writing up the desired outcome by saying that I wanted
to skip blocks of data that don’t have “net†dollar amounts in column P. I
now realize that in those instances I would really like the macro to return
the: symbol, the start date as the top date of the column for its block, the
end date as the bottom date of its block and the dollar net amount to be
blank.

Thanks so much.

 

[John Yab]

Hi Joel,

Thanks. Wow. I had not even seen code like yours, before.
It gets real close to the desired resullts.
It doesn't return results to the summary sheet for the last block of data
that it collects data from, though. I have tried for hours to modify your
code to adjust for that but I just can't get it. Your code is at a high level
I have not got to yet.
Can you modify it a bit to eliminate the extra summary rows caused by the
areas in column P that don't have formulas?
I made a mistake with writing up the desired outcome by saying that I wanted
to skip blocks of data that don’t have “net†dollar amounts in column P. I
now realize that in those instances I would really like the macro to return
the: symbol, the start date as the top date of the column for its block, the
end date as the bottom date of its block and the dollar net amount to be
blank.
I will keep trying on my own and appreciate your help. I will also have to
do more research to learn about some new concepts that your code has shown me.
Thank you very much.

 

[John Yab]

Hi Joel,
It works. It's cool. Thank you very much.

I tried all evening to make a modification when there isn't “net†dollar
amounts in column P in a block:
to to return the: symbol, the start date as the top date of the column for
its block, the
end date as the bottom date of its block and the dollar net amount to be
blank or 0.
I thought if I put in a 0 at the end of column P of those blocks empty of
"net" then your code would return entries to the summary sheet. I haven't got
that mod to work yet, below is the code. Would you be able to help a bit
more? Also where can I learn about: "Enum States", "FindNet = 1", "End Enum"
kind of code... a book you could recomend, maybe?

Thanks so much.



Enum States
FindNet = 1
FindAmount = 2
End Enum
Sub MakeSummaryVJ15()

Dim State As States

'Delete the sheet "Summary" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Worksheets("Summary").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a new summary worksheet.
Set Sumsht =
ActiveWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
Sumsht.Name = "Summary"


'Set up titles
'Range("A11") = Array("Symbol", "Start", "End", "Net")
Columns("B").HorizontalAlignment = xlRight

NewRow = 2
'Set Sumsht = Sheets("Summary")

With Sumsht
..Range("A1") = "Symbol"
..Range("B1") = "Start"
..Range("C1") = "End"
..Range("D1") = "Net"
..Rows("1:1").Font.Bold = True
End With

For Each OldSht In Sheets
With OldSht
If .Range("A1") = "Ticker" Then
State = FindNet
LastRow = .Range("P" & Rows.Count).End(xlUp).Row
For RowCount = 1 To LastRow
Data = .Range("P" & RowCount)

Select Case State

Case FindNet:
If Data = "Net" Then
State = FindAmount
startDate = .Range("B" & (RowCount + 1))
End If

Case FindAmount:
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
If Data = "" Then
Cells.Offset(-2, 0).Value = "0"
ElseIf Data <> "" Then
If Data <> "Net" Then
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'found first dollar amount
ID = .Range("A" & RowCount)
endDate = .Range("B" & RowCount)
With Sumsht
..Range("A" & NewRow) = ID
..Range("B" & NewRow) = startDate
..Range("C" & NewRow) = endDate
..Range("D" & NewRow) = Data

NewRow = NewRow + 1
End With

State = FindNet
End If
End If
End Select
Next RowCount
End If
End With
Next OldSht
End Sub

 

[John Yab]

It's perfect.
I can't thank you enough.
I have been working on this every evening and all last weekend for over a
week.
Not only is it perfect but now I can learn the new concepts that you have
shown me.
Totally grateful, thank you.

 

[Don Guillett]

This also works

Sub GetDataAllSheetsSAS() 'insert a row at the top of the sheet
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim firstaddress
Dim r As Long
Dim lr As Long
Dim i As Long
Dim c As Range

With Sheets("Summary")
lr = .Cells(Rows.Count, 1).End(xlUp).Row
..Rows(2).Resize(lr).Delete
End With

r = 2
For Each ws In Worksheets
If ws.Name <> "Summary" And ws.Range("a1") = "Ticker" Then

lr = ws.Cells(Rows.Count, "a").End(xlUp).Row
With ws.Range("p1" & lr)
Set c = .Find(What:="Net", after:=ws.Range("p" & lr), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False)

If Not c Is Nothing Then
firstaddress = c.Address
Do

With Sheets("summary")
..Cells(r, "e") = ws.Name
..Cells(r, "a") = ws.Cells(c.Row + 1, 1) 'symbol
..Cells(r, "b") = ws.Cells(c.Row + 1, 2) 'startdate
..Cells(r, "c") = ws.Cells(c.Row + 1, 2).End(xlDown) 'enddate
For i = c.Row + 1 To ws.Cells(Rows.Count, 1).End(xlUp).Row

If Len(ws.Cells(i, "p")) > 0 Then
If ws.Cells(i, "p") = "Net" Then
..Cells(r, "d") = 0 'end value
Else
..Cells(r, "d") = ws.Cells(i, "p") 'end value
End If

Exit For
End If
Next i

End With
r = r + 1

Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
End If
'MsgBox ws.Name
Next ws
Application.ScreenUpdating = True
End Sub

 

[Don Guillett]

OOPs NOT necessary to insert a row at the top

--
Don Guillett
Microsoft MVP Excel
SalesAid Software
(e-mail address removed)

This also works

Sub GetDataAllSheetsSAS() 'insert a row at the top of the sheet
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim firstaddress
Dim r As Long
Dim lr As Long
Dim i As Long
Dim c As Range

With Sheets("Summary")
lr = .Cells(Rows.Count, 1).End(xlUp).Row
.Rows(2).Resize(lr).Delete
End With

r = 2
For Each ws In Worksheets
If ws.Name <> "Summary" And ws.Range("a1") = "Ticker" Then

lr = ws.Cells(Rows.Count, "a").End(xlUp).Row
With ws.Range("p1" & lr)
Set c = .Find(What:="Net", after:=ws.Range("p" & lr), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False)

If Not c Is Nothing Then
firstaddress = c.Address
Do

With Sheets("summary")
.Cells(r, "e") = ws.Name
.Cells(r, "a") = ws.Cells(c.Row + 1, 1) 'symbol
.Cells(r, "b") = ws.Cells(c.Row + 1, 2) 'startdate
.Cells(r, "c") = ws.Cells(c.Row + 1, 2).End(xlDown) 'enddate
For i = c.Row + 1 To ws.Cells(Rows.Count, 1).End(xlUp).Row

If Len(ws.Cells(i, "p")) > 0 Then
If ws.Cells(i, "p") = "Net" Then
.Cells(r, "d") = 0 'end value
Else
.Cells(r, "d") = ws.Cells(i, "p") 'end value
End If

Exit For
End If
Next i

End With
r = r + 1

Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
End If
'MsgBox ws.Name
Next ws
Application.ScreenUpdating = True
End Sub

 

[John Yab]

Thanks Don,

Yes yours works perfectly too.
I have run it many times and will now study it to learn from it.
Hopefully one day I will be able to help by providing answers like you have
kindly done for me.
Thank you very much for working on this for me.
--
John Yab

OOPs NOT necessary to insert a row at the top