pulling data from an excel workbook

[david shapiro]

I've created an excel workbook with several worksheets.
In each worksheet, I've highlighted a number of the cells containing key
statistics in red.

Is there any easy one-step way that I can pull all of the cells
highlighted in red out of all of the worksheets in the workbook and list
them all in one separate worksheet? Or is there a macro you might
suggest?

Unfortunately, the red cells are not in any systematic order in the
worksheets (all the worksheets are rather different). Pulling the red
cells out would just have to be on the basis of color.

Àlso, if I have say 100 worksheets in a workbook each with a dataset, is
there a straightforward, one-step way that I could put all of the
datasets in the worksheets onto one worksheet?

Thank you.

Dave Shapiro

 

[Dave Peterson]

Maybe something like this that loops through each cell in the usedrange of each
worksheet:

Option Explicit
Sub testme01()

Dim wks As Worksheet
Dim SumWks As Worksheet
Dim myCell As Range
Dim oRow As Long

Set SumWks = Worksheets.Add
SumWks.Range("a1").Resize(1, 4).Value _
= Array("Sheet", "address", "value", "formula")

oRow = 1
For Each wks In ActiveWorkbook.Worksheets
If wks.Name = SumWks.Name Then
'do nothing
Else
With SumWks
For Each myCell In wks.UsedRange.Cells
If myCell.Interior.ColorIndex = 3 Then
oRow = oRow + 1
.Cells(oRow, "A").Value = "'" & wks.Name
.Cells(oRow, "B").Value = myCell.Address(0, 0)
.Cells(oRow, "C").Value = "'" & myCell.Value
.Cells(oRow, "D").Value = "'" & myCell.Formula
End If
Next myCell
End With
End If
Next wks
End Sub

(I'm not sure what your red's colorindex is, though.)

 

[david shapiro]

Dave,

Thanks for the VB code for extracting data from worksheets by color.

Rather than checking the entire worksheet cell by cell for colored
cells, I`m thinking it might be easier if the programme just checks the
second column of every row in the worksheet.

If it is red, then extract the entire row of cells of data and list all
the rows in the new worksheet. This would be done for all of the
worksheets in the workbook. So the new worksheet would contain all the
red rows from all the worksheets in the workbook.

All of rows in the worksheets have a standard number of columns (from
columns A to AB on the excel sheet). (If possible, it would be good if
the computer flagged when a worksheet did not have the standard A to AB
number of columns.)

How can I find out the right number for red in my color index?

I`ve also created the following code for preparing each of the
worksheets for the extraction process:

Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Range("C1").Select
Selection.Copy
Range("A1").Select
ActiveSheet.Paste
Columns("A:C").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Application.CutCopyMode = False
Selection.FormulaR1C1 = "=R[-1]C"
End Sub

Would it be possible to alter the code so that it runs this procedure on
every worksheet in the workbook? And then add the extraction procedure
(which creates the new data sheet and extract the rows of data by color)
after this.

Overall, this is what the VB does:

1) It prepares the worksheets for the extraction process (this is done
for each worksheet in the workbook): the procedure for each worksheet
is above.

2) When all worksheets prepared, a new empty data sheet is created.

3) Search through each row of the worksheet for every row where the
second column is red. If column 2 of the row is red, extract the whole
row of cells and list in the new data sheet. Do procedure for all
worksheets.

4) New data sheet contains all rows in worksheets in workbook for which
the second column is red.

Hope the description isn`t too complicated. Thanks very much.

Dave

 

[Dave Peterson]

You could use your existing code and just select a sheet, run your code, select
a different sheet, run your code...

Sub doall()
dim wks as worksheet
for each wks in activeworkbook.worksheets
wks.select
call yourproc
next wks
end sub

or if you include it in the newer version:

Option Explicit
Sub testme01()

Dim wks As Worksheet
Dim SumWks As Worksheet
Dim myCell As Range
Dim oRow As Long

Set SumWks = Worksheets.Add

oRow = 0
For Each wks In ActiveWorkbook.Worksheets
If wks.Name = SumWks.Name Then
'do nothing
Else
wks.Select
Call YourProc
For Each myCell In Intersect(wks.UsedRange, wks.Columns(2)).Cells
If myCell.Interior.ColorIndex = 3 Then
oRow = oRow + 1
myCell.EntireRow.Copy _
Destination:=SumWks.Cells(oRow, "A")
End If
Next myCell
End If
Next wks
End Sub

sub YourProc()
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Range("C1").Select
Selection.Copy
Range("A1").Select
ActiveSheet.Paste
Columns("A:C").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Application.CutCopyMode = False
Selection.FormulaR1C1 = "=R[-1]C"
End Sub


I think I'd add a formula after all the copying is done:

=counta(B1:IV1) after inserting a new column A.

Then I could tell how many entries are in each row. (This'll work ok if no
cells are empty).

Dave,

Thanks for the VB code for extracting data from worksheets by color.

Rather than checking the entire worksheet cell by cell for colored
cells, I`m thinking it might be easier if the programme just checks the
second column of every row in the worksheet.

If it is red, then extract the entire row of cells of data and list all
the rows in the new worksheet. This would be done for all of the
worksheets in the workbook. So the new worksheet would contain all the
red rows from all the worksheets in the workbook.

All of rows in the worksheets have a standard number of columns (from
columns A to AB on the excel sheet). (If possible, it would be good if
the computer flagged when a worksheet did not have the standard A to AB
number of columns.)

How can I find out the right number for red in my color index?

I`ve also created the following code for preparing each of the
worksheets for the extraction process:

Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Range("C1").Select
Selection.Copy
Range("A1").Select
ActiveSheet.Paste
Columns("A:C").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Application.CutCopyMode = False
Selection.FormulaR1C1 = "=R[-1]C"
End Sub

Would it be possible to alter the code so that it runs this procedure on
every worksheet in the workbook? And then add the extraction procedure
(which creates the new data sheet and extract the rows of data by color)
after this.

Overall, this is what the VB does:

1) It prepares the worksheets for the extraction process (this is done
for each worksheet in the workbook): the procedure for each worksheet
is above.

2) When all worksheets prepared, a new empty data sheet is created.

3) Search through each row of the worksheet for every row where the
second column is red. If column 2 of the row is red, extract the whole
row of cells and list in the new data sheet. Do procedure for all
worksheets.

4) New data sheet contains all rows in worksheets in workbook for which
the second column is red.

Hope the description isn`t too complicated. Thanks very much.

Dave

 

[david shapiro]

Dave,

It works great. Many thanks!!

Dave Shapiro

 

[david shapiro]

Dave,

Had just wanted to thank you again for the program to pull out data from
a dataset based on color.

I also tried out your initial suggestion for doing this which was
(attached below). But somehow in creating it, there is always an error
which comes up at the line:
= Array("Sheet", "address", "value", "formula")
The whole line becomes red, and the error message is something referring
to "end of statement" or something like that.

Do you know what the problem might be and how to fix it?

Thanks.

Dave Shapiro

your original suggestion:

"Maybe something like this that loops through each cell in the usedrange
of each worksheet:"

Option Explicit
Sub testme01()

Dim wks As Worksheet
Dim SumWks As Worksheet
Dim myCell As Range
Dim oRow As Long

Set SumWks = Worksheets.Add
SumWks.Range("a1").Resize(1, 4).Value _
= Array("Sheet", "address", "value", "formula")

oRow = 1
For Each wks In ActiveWorkbook.Worksheets
If wks.Name = SumWks.Name Then
'do nothing
Else
With SumWks
For Each myCell In wks.UsedRange.Cells
If myCell.Interior.ColorIndex = 3 Then
oRow = oRow + 1
.Cells(oRow, "A").Value = "'" & wks.Name
.Cells(oRow, "B").Value = myCell.Address(0, 0)
.Cells(oRow, "C").Value = "'" & myCell.Value
.Cells(oRow, "D").Value = "'" & myCell.Formula
End If
Next myCell
End With
End If
Next wks
End Sub

 

[Dave Peterson]

Did you insert any additional lines?

These two physical lines are really just one logical line (space underscore is
the continuation character):

SumWks.Range("a1").Resize(1, 4).Value _
= Array("Sheet", "address", "value", "formula")

Try pasting them one more time.

And if that doesn't work, try typing them in. Maybe you're picking something up
when you copy from the web page (http://www.developersdex.com).

(or go to google, find this thread and copy|paste from there.)

ah, heck. here's a link to google:
http://groups.google.com/[email protected]

 

[david shapiro]

Dave,

I must admit I did try to rework your original programme, combining it a
bit with the second programme you suggested in order to pull out the red
cells but this time listing them one at a time on the new sheet (instead
of the whole row).

I think I may have created a bit of a mess as I had reworked the line
to:

SumWks.Range("a1").Resize(1, 5).Value _
= Array("city", "store", "product", "year","sales")
(and also a few other lines)

What I was trying to do is - this is the dataset:

value of sales

city store product 1995 2000 2001 2002
Tampa Walmart shoes 126 222 378 498
NYC Macy television 33 26 78 76
Boston Walmart computers 257 876 343 798

Similar to the program pulling out all the lines with a red color in the
2nd column, how could the programme be reworked so that:

- the computer goes into the worksheet, goes into each cell and checks
for any red cells for sales values under the year field headings
- if the cell is red, then the sales value is extracted and listed in
the new sheet in the following form and under these field headings:
city store product year salesvalue
- go through each cell in the worksheet checking for red
- run through all of the worksheets in the workbook.
(field headings start on row 5 in every worksheet, years are always from
columns 4-7 across)

So, for example in the dataset above if the numbers (salesvalues) 222,
78, 76 and 343 were highlighted in red, in the new worksheet the
following field headings and list would appear:

city store product year value
Tampa Walmart shoes 2000 222
NYC Macy television 2001 78
NYC Macy television 2002 76
Boston Walmart computers 2001 343

I realized this would be an even more direct way of extracting the data
highlighted in red than the whole line at a time.

Hope I've been able to describe it clearly. Thanks.

Dave

 

[Dave Peterson]

You want to look at D6:G????

I used column A to determine that last row.

Option Explicit
Sub testme01()

Dim wks As Worksheet
Dim SumWks As Worksheet
Dim myCell As Range
Dim oRow As Long
Dim myRng As Range

Set SumWks = Worksheets.Add
SumWks.Range("a1").Resize(1, 5).Value _
= Array("city", "store", "product", "year", "sales")

oRow = 1
For Each wks In ActiveWorkbook.Worksheets
If wks.Name = SumWks.Name Then
'do nothing
Else
With wks
Set myRng = .Range("d6:g" & _
.Cells(.Rows.Count, "A").End(xlUp).Row)
End With
With SumWks
For Each myCell In myRng.Cells
If myCell.Interior.ColorIndex = 3 Then
oRow = oRow + 1
.Cells(oRow, "A").Value _
= wks.Cells(myCell.Row, "A").Value
.Cells(oRow, "B").Value _
= wks.Cells(myCell.Row, "B").Value
.Cells(oRow, "C").Value _
= wks.Cells(myCell.Row, "C").Value
.Cells(oRow, "D").Value _
= wks.Cells(5, myCell.Column).Value
.Cells(oRow, "E").Value _
= myCell.Value
End If
Next myCell
End With
End If
Next wks
End Sub

Seemed to work ok in minor testing.

 

[david shapiro]

Dave,

Again it works terrific. Many thanks!!

From the new smaller dataset (all the extractions through red color) in
the new worksheet, I'm wondering if it might be possible to add this
step:

- take all of the data in the first four columns under the field
headings "city", "store", "product", "year"
- go to worksheet in workbook called "all data" and using this data as
criteria (field headings: "city", "store", "product", "year"), run an
advanced filter to extract all the data meeting this criteria from the
larger dataset called "all data".
- put this extracted data in a separate newly created worksheet
- put a protect on the newly created worksheet with the extraction from
the advanced filter, so that it can only be altered through password
(any password ok).

There are about 10 field headings in "all data", so the filter would
have to look specifically for all datalines meeting only the four
criteria "city", "store", "product", "year".

I hope this isn't becoming too extravagant, would be great if this step
could be added. Looking forward to your suggestions.

Dave Shapiro

 

[Dave Peterson]

Debra Dalgleish has some workbooks that do this (albeit with a single column).
But she does an advanced filter to obtain just the unique entries. Then cycles
through this list. She creates a new worksheet based on this extraction, but
the beginning of the code might help you.

And if you try recording a macro when you do it once, what happens?

Link to Debra's site:

http://www.contextures.com/excelfiles.html#Filter

She has two versions:

Update Sheets from Master -- uses an Advanced Filter to send data from
Master sheet to individual worksheets -- creates a list of unique items, creates
a sheet for each item, then replaces old data with current. AdvFilterCity.xls
44 kb

Create New Sheets from Filtered List -- uses an Advanced Filter to create
separate sheet of orders for each sales rep visible in a filtered list; macro
automates the filter. AdvFilterRepFiltered.xls 35 kb

 

[david shapiro]

Dave,

Just had a question referring back to the original code in the line:

Set myRng = .Range("d6:g" & _
.Cells(.Rows.Count, "A").End(xlUp).Row)

Is the d6 referring to the first cell where the prgramme starts looking
for red cells.

How is the best way to handle this if this cell varies from worksheet to
worksheet. But it is always the cell at the intersection of the column
which contains the words "year" somewhere in the worksheet and the row
which contains the word "ZZZ" somewhere in the worksheet. How would be
the best way to do the above range line, taking this into consideration?

Don't mean to bring this up again, but if you have a chance, am
wondering if you might know how to go about the last part of the macro
code I had sent:

Take the dataset in the worksheet "final data" which has several columns
which have various headings. Add new column as the first column and
give it the heading "indicator id". The objective is to find the
indicator id code there for the data in the row, to loop through and do
this row by row until the end of the dataset.

The indicator ID code can be found in the "reference" worksheet. The
correct indicator id code in the "reference" file is the one for which
the data row in the worksheets "final data" and "reference" shares the
same contents in the columns headed by:
indicator, subgroup, gender and measurement.

I have thought one possible way might be to cacatenate the indicator,
subgroup, gender and measurement columns in both the "source data" and
"reference" worksheets, compare them using a vlookup to find the correct
indicator id code in the "reference" worksheet, and then put that
indicator id code in the created blank column (1st column) in the "final
data" worksheet. And to loop through so it does this for all the rows
one at a time. it would be good too if all the rows for which an
indicator id code could not be found in the "reference" worksheet are
put in a separate newly created worksheet page.

Some suggestions on this would be appreciated.

Regards,
Dave

 

[Dave Peterson]

First, I didn't look at your code.

But for this question, I'd look for those values:

Dim FoundYearCell As Range
Dim FoundZZZCell As Range
Dim wks As Worksheet
Dim myRng As Range

Set wks = Worksheets("sheet1") 'whatever??

With wks.Cells
Set FoundYearCell = .Find(what:="Year", after:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
lookat:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)

Set FoundZZZCell = .Find(what:="zzz", after:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
lookat:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)

If FoundYearCell Is Nothing _
Or FoundZZZCell Is Nothing Then
MsgBox "Something's missing"
Else
Set myRng = .Range(.Cells(FoundZZZCell.Row, FoundYearCell.Column), _
.Cells(.Rows.Count, FoundYearCell.Column).End(xlUp))
End If

(You may want to go back to your thread with Bob Kilmer. He seems to have it
well in hand.)

 

[david shapiro]

Dave,

A while back you had suggested recording while doing an advanced filter
to get the right code for this. This is what I got in doing this. How
could this code be adjusted so it's no longer hardcoded but
automatically takes the full data in both "source data" and "criteria
file"?

Dave

Sheets("source data").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Range("A1:I2754").AdvancedFilter Action:=xlFilterInPlace,
CriteriaRange:= _
Sheets("criteria file").Range("A1:G5"), Unique:=False
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets.Add
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Sheets("Sheet3").Select
Sheets("Sheet3").Name = "final data"
End Sub

 

[Dave Peterson]

Dim LastRow as long
dim myRng as range
with worksheets("source data")
lastrow = .cells(.rows.count,"A").end(xlup).row
set myRng = .range("a1:I"&lastrow)
myrng.advancedfilter...rest of your code
end with

I used column A to determine the last row on "Source data".

Did you really want to filter on all those columns?

 

[david shapiro]

Dave,

I know it's a lot of columns, but believe or not yes, I do need to
filter based on the criterion in all the columns.

Just to make sure I've put your new code in right - is this the correct
whole thing? How could the hard coding in the range for the "criteria
file" (A1:G5) also be made to automatically take the whole dataset in
the "criteria file"? (Does this filter in place in which case I've
added a select visible cells, copy and paste to a new worksheet?)

Dim LastRow as long
dim myRng as range
with worksheets("source data")
lastrow = .cells(.rows.count,"A").end(xlup).row
set myRng = .range("a1:I"&lastrow)
myrng.advancedfilter.AdvancedFilter Action:=xlFilterInPlace,

CriteriaRange:= _
Sheets("criteria file").Range("A1:G5"), Unique:=False

end with

' the rest of the code just takes the output, selects visible cells and
pastes it to a new worksheet
Selection.SpecialCells(xlCellTypeVisible).Select

Selection.Copy
Sheets.Add
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Sheets("Sheet3").Select
Sheets("Sheet3").Name = "final data"
End Sub

Have I've put it together right? Thanks.

Dave

 

[Dave Peterson]

If you want the last usedrow of A:G in the criteria range:

dim CritLastRow as long
dim tempRow as long
dim iCtr as long
critlastrow = 1
with worksheets("criteria file")
for ictr = 1 to 5
temprow = .cells(.rows.count,ictr).row
if temprow > critlastrow then
critlastrow = temprow
end if
end with

.....
then later...

...., Sheets("criteria file").Range("A1:G" & critlastrow), Unique:=False

 

[david shapiro]

Dave,

Somehow I`m coming up with an error:
compile error, end with without with

Did I combine the two parts right? (code below)

Dave

Private Sub advfilter()

Dim CritLastRow As Long
Dim tempRow As Long
Dim iCtr As Long
CritLastRow = 1
With Worksheets("criteria file")
For iCtr = 1 To 5
tempRow = .Cells(.Rows.Count, iCtr).Row
If tempRow > CritLastRow Then
CritLastRow = tempRow
End If
End With
Dim LastRow As Long
Dim myRng As Range
With Worksheets("source data")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set myRng = .Range("a1:i" & LastRow)
myRng.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Sheets("criteria file").Range("A1:G" & CritLastRow), Unique:=False
End With
'
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets.Add
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("Sheet3").Select
Sheets("Sheet3").Name = "final data"
End Sub

 

[Dave Peterson]

Sorry, I missed a "next ictr" line in this portion:

With Worksheets("criteria file")
For iCtr = 1 To 5
tempRow = .Cells(.Rows.Count, iCtr).Row
If tempRow > CritLastRow Then
CritLastRow = tempRow
End If
Next iCtr '<---- oops!
End With