collecting rows into summary sheet

[fearfour]

Hi everyone, I need to copy all rows with the phrase "bid price too high" and "bid price too low" and paste them into a summary sheet. I have several sheets with this data in them. Some of these sheets are longer or shorter (i.e. more or fewer rows but the columns are all the same). More specifically, the data that I need to summarize appears in sheets 5 through 12 of my workbook, and I would like to copy the rows into a page called "Summary". Any ideas? Thank you so much for your help!

example.xls
	P	Q	R	S
4	Pricedifference(MostRecentPriceminusBidPrice)	Price-differences[%](CurrentvsBidPrice)	RedFlag(Pricebidtoohigh/low)
5	-$1.20	19.87%
6	$0.12	-9.23%
7	-$0.13	24.51%
8	$0.27	-23.08%
9	-$0.02	2.08%
10	$0.08	-6.82%
11	$0.07	-6.48%
12	-$0.04	3.74%
13	-$0.12	8.89%
14	-$0.07	6.09%
15	-$0.05	3.73%
16	$0.41	-45.56%	BidPriceTooLow!
17	$0.03	-2.34%
18	$0.12	-8.76%
19	$0.07	-3.66%
20	-$0.22	24.72%
21	$0.16	-9.47%
22	-$0.16	21.83%
23	$0.10	-9.80%
24	-$0.59	45.38%	BidPriceTooHigh!
25	$0.14	-28.00%
26	-$0.02	5.26%
Sheet1

 

[Smitty]

How's this for a start:

<font face=Tahoma><SPAN style="color:#00007F">Sub</SPAN> foo()
    <SPAN style="color:#00007F">Dim</SPAN> c <SPAN style="color:#00007F">As</SPAN> Range, LastRow <SPAN style="color:#00007F">As</SPAN> Range
    <SPAN style="color:#00007F">Dim</SPAN> i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>
        Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN>
            <SPAN style="color:#00007F">For</SPAN> i = 5 <SPAN style="color:#00007F">To</SPAN> 12
                <SPAN style="color:#00007F">With</SPAN> Sheets(i)
                    .Activate
                    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> c <SPAN style="color:#00007F">In</SPAN> Range([C2], Cells(Rows.Count, "C").End(xlUp))
                        <SPAN style="color:#00007F">If</SPAN> Left(c, 3) = "Bid" <SPAN style="color:#00007F">Then</SPAN>
                            <SPAN style="color:#00007F">Set</SPAN> LastRow = Sheets("Summary").Cells(Rows.Count, "A").End(xlUp)
                                <SPAN style="color:#00007F">With</SPAN> LastRow
                                    .Offset(1) = c.Offset(, -2)
                                    .Offset(1, 1) = c.Offset(, -1)
                                    .Offset(1, 2) = c
                                <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN>
                            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN>
                        <SPAN style="color:#00007F">Next</SPAN> c
                    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN>
                <SPAN style="color:#00007F">Next</SPAN> i
                Sheets("Summary").Activate
            Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN>
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>

HTH,

Smitty

(I'm outta' here for the day! )

 

[fearfour]

Hey there Pennysaver, should I change the ranges labeled "C" to R since the column containing the flag is R?

 

[fearfour]

Also, can we make it so that it copies the WHOLE row?

 

[pfarmer]

Hi everyone, I need to copy all rows with the phrase "bid price too high" and "bid price too low" and paste them into a summary sheet. I have several sheets with this data in them. Some of these sheets are longer or shorter (i.e. more or fewer rows but the columns are all the same). More specifically, the data that I need to summarize appears in sheets 5 through 12 of my workbook, and I would like to copy the rows into a page called "Summary". Any ideas? Thank you so much for your help!

I'll post the following as is. Basically in this example it cycles through all sheets (there are 250+ of them) and transfers all rows starting on row three from each sheet to a summary sheet called 'Master'. With the data in each sheet, the sheet name precedes it (the sheet names are the companies involved, the data their employees).

In your case you would be doing basically the same but you would check to see if values are too high or too low.

Basically this is code picked up elsewhere that I modified for my use. I was surprised at its speed, for 4500 entries on a relatively slow machine it took under two seconds.

If you take a close look I think you will see that it is actually very similar in concept to pennysavers (which means you may want to use his instead and modify it for your needs). To the concept is added a few items such as autofit, etc. of columns, the creation of the 'Master' sheet, column headers, but it is basically the same concept.

Sub CopyFromWorksheets()
    Dim wrk As Workbook 'Workbook object - Always good to work with object variables
    Dim sht As Worksheet 'Object for handling worksheets in loop
    Dim trg As Worksheet 'Master Worksheet
    Dim rng As Range 'Range object
    Dim colCount As Integer 'Column count in tables in the worksheets
    Dim n
    n = 1
    
    Set wrk = ActiveWorkbook 'Working in active workbook
      
'    For Each sht In wrk.Worksheets
'        If sht.Name = "Master" Then
'            MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
'            "Please remove or rename this worksheet since 'Master' would be" & _
'            "the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
'            Exit Sub
'        End If
'    Next sht
      
     'We don't want screen updating
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
On Error Resume Next
    Sheets("Master").Delete

    Application.DisplayAlerts = True
     'Add new worksheet as the last worksheet
    Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
     'Rename the new worksheet
    trg.Name = "Master"
     'Get column headers from the first worksheet
     'Column count first
    Set sht = wrk.Worksheets(1)
    colCount = sht.Cells(1, 255).End(xlToLeft).Column + 3
     'Now retrieve headers, no copy&paste needed
    With trg.Cells(1, 2).Resize(1, colCount)
        .Value = sht.Cells(1, 1).Resize(1, colCount).Value
        .Font.Bold = True
    End With
    trg.Cells(1, 1) = "Contractor"
    trg.Cells(1, 1).Font.Bold = True
    trg.Cells(1, 7) = "Contractor List"
    trg.Cells(1, 7).Font.Bold = True
        
     'We can start loop
    For Each sht In wrk.Worksheets
         'If worksheet in loop is the last one, stop execution (it is Master worksheet)
        If sht.Index = wrk.Worksheets.Count Then
            Exit For
        End If
        n = n + 1
         'Data range in worksheet - starts from third row as first rows are the header rows in all worksheets
        Set rng = sht.Range(sht.Cells(3, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))

         'Put data into the Master worksheet
        trg.Cells(65536, 2).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
        trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, 1).Value = sht.Name
    trg.Cells(n, 7).Value = sht.Name
    Next sht
     'Fit the columns in Master worksheet
    trg.Columns.AutoFit

    Range("G2").Select
    ActiveWindow.FreezePanes = True

     'Screen updating should be activated
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
 
End Sub

Perry

 

[Smitty]

should I change the ranges labeled "C" to R since the column containing the flag is R?

Yes.

Also, can we make it so that it copies the WHOLE row?

Yes, by replacing the With LastRow part with:

c.EntireRow.Copy LastRow(Offset(1)

Smitty

 

[fearfour]

Hi Pennysaver, this code does not seem to work for me, even when I try using it just as-is. It produces an error at the line

With Sheets(i)
.Activate


Also in terms of copying the whole row, do you mean that I should replace the entire three lines

.Offset(1) = c.Offset(, -2)
.Offset(1, 1) = c.Offset(, -1)
.Offset(1, 2) = c

With just the line:

c.EntireRow.Copy LastRow(Offset(1)

Also, it looks to me like that is missing a parenthesis.....

At any rate I would love to use this macro but it is just not working...

Thanks for your help though!

 

[Smitty]

It produces an error at the line

With Sheets(i)
.Activate

I don't know why it would be failing there unless the sheets are hidden.

Also in terms of copying the whole row, do you mean that I should replace the entire three lines

Yes, replace the entire With statement.

c.EntireRow.Copy LastRow(Offset(1)

Also, it looks to me like that is missing a parenthesis.....

Sorry, typo on my part, it should be:

c.EntireRow.Copy LastRow.Offset(1)

Sub foo()
    Dim c As Range, LastRow As Range
    Dim i As Integer
        Application.ScreenUpdating = False
            For i = 5 To 12
                With Sheets(i)
                    .Activate
                    For Each c In Range([R2], Cells(Rows.Count, "R").End(xlUp))
                        If Left(c, 3) = "Bid" Then
                            Set LastRow = Sheets("Summary").Cells(Rows.Count, "A").End(xlUp)
                             c.EntireRow.Copy LastRow.Offset(1)
                         End If
                      Next c
                    End With
                Next i
                Sheets("Summary").Activate
            Application.ScreenUpdating = True
End Sub

The code could be simplified, but I wrote it on the way out the door last night. Let's get it working first though...

Smitty