Copying columns from multiple sheets in a single sheet based on a column value.

[deuxstatic]

Hello,

This is tricky to explain... Lets say I have 6 worksheets, "apples",
"oranges", "pears", "basket1", "basket2", & "basket3".

The "basket1", "basket2", & "basket3" sheets contain information in
column format were one of the values in the column will be the type of
fruit and then the rest of the values in that column will be about
that particular piece of fruit.

I need to copy only the columns out of worksheets "basket1",
"basket2", & "basket3" that have the value "apple" in say row 2 - and
paste those values into the "apples" sheet. Then repeat for the
"oranges" & "pears" sheets.

Thank you in advance for you help.
Starla

 

[Damien McBain]

Hello,

This is tricky to explain... Lets say I have 6 worksheets, "apples",
"oranges", "pears", "basket1", "basket2", & "basket3".

The "basket1", "basket2", & "basket3" sheets contain information in
column format were one of the values in the column will be the type of
fruit and then the rest of the values in that column will be about
that particular piece of fruit.

I need to copy only the columns out of worksheets "basket1",
"basket2", & "basket3" that have the value "apple" in say row 2 - and
paste those values into the "apples" sheet. Then repeat for the
"oranges" & "pears" sheets.

This looks through the cells in column A (down to the one above the first
blank cell) in a worksheet called "data" and copies the first 11 cells in
the row into another worksheet with the same name as the value in the cell.
You should be able to modify it to achieve what you described.
"SheetsExist" is a function that tests to see if the sheet exists and
returns a boolean (true or false) - I found it on the net and can't claim
authorship!. I've added that function below the PolulateDetail macro.
===========================================
Sub PopulateDetail()
On Error GoTo Hell

Dim WSObj As Object
Dim wbname
Dim wsname
wbname = "Subcontractor Payments.xls"

For Each rcd In Worksheets("Data").Range("A2",
Worksheets("Data").Range("A2").End(xlDown))

If SheetExists(CStr(rcd)) Then

Worksheets("Data").Range(rcd, rcd.Offset(0, 11)).Copy
Worksheets(CStr(rcd.Value)).Range("A65536").End(xlUp).Offset(1,
0).PasteSpecial xlPasteValues

Else

Worksheets("Data").Range(rcd, rcd.Offset(0, 11)).Copy
Worksheets("Other").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
xlPasteValues

End If

Next rcd

Gout:
Exit Sub
Hell:
MsgBox Err.Description
Resume Gout

End Sub
============================================
Function SheetExists(Sh As String, Optional wb As Workbook) As Boolean

Dim oWs As Worksheet
If wb Is Nothing Then Set wb = ActiveWorkbook
On Error Resume Next
SheetExists = CBool(Not wb.Worksheets(Sh) Is Nothing)
On Error GoTo 0

End Function