info mtg criteria from one wkbk to another

[bkinman]

I need to extract select information from one workbook into another workbook
if the contents of one cell matches 1 of 4 numbers. It does not need to be in
the same order (col2 comes before col1 in the destination wkbk) so a simple
copy and paste is not the best answer.

wkbk1
col 1 col 2 col3 col4 col5 col6
col7 etc......
empid dept# ann sal. hire date title address name
123 535 22000 1/2/90 txt
122 726 30000 12/16/09 txt
178 513 25000 2/10/02 txt
552 810 42000 6/7/08 txt

Destination wkbk
name doh dept# ann sal

I only need it copied over if the dept# is equal to 513,535,540, or 560 and
only certain columns.

Any suggestions would be greatly appreciated.

 

[GSnyder]

Interesting problem... Some VBA would solve it nicely. I assumed the
following:

1. The source data is laid out like you had in your example, on a sheet
called Source
2. A1:G1 on source are column headings and the data is in A2:Gxxx
3. You want to copy to a sheet called Destination.
4. A11 on Destination are headers and the data you need will be in A2xxx
5. You have a list of the departments that you'd like to copy over in range
G1:Gxxx where G1 is actually a header row ("Depts Needed" or something like
that). This will give you the flexibility to copy 1, 2, 3, or 17 depts over
to Destination.

If you have it set up like that, this code should work:

Sub Copydata()
Dim rngCell, rngDept, rngDepts, rngSource As Range

Sheets("Source").Select
Set rngSource = Range("B2:B" & Range("B1").End(xlDown).Row)

Sheets("Destination").Select
Set rngDepts = Range("G2:G" & Range("G1").End(xlDown).Row)

' Select and clear the destination range
Range("A2").Select
Range("A25000").ClearContents

' Now walk down the source range
For Each rngCell In rngSource
For Each rngDept In rngDepts
If rngDept = rngCell Then bFound = True
Next
' If we had a hit, then...
If bFound = True Then
' copy all of the data
ActiveCell = rngCell.Offset(0, 5)
ActiveCell.Offset(0, 1) = rngCell.Offset(0, 2)
ActiveCell.Offset(0, 2) = rngCell
ActiveCell.Offset(0, 3) = rngCell.Offset(0, 1)

' Move to the next destination cell
ActiveCell.Offset(1, 0).Select
bFound = False
End If
Next

End Sub

 

[Chris Bode]

Try following code.
Place a command button on the sheet from the control box


Code
-------------------

Private Sub CommandButton1_Click()
Dim row1 As Integer, col1 As Integer
Dim row2 As Integer, col2 As Integer

row1 = 1
col1 = 1

row2 = 1
col2 = 1

While Workbooks(1).Sheets(1).Cells(row, col).Value <> ""

If (Workbooks(1).Sheets(1).Cells(row1, col1 + 1).Value = "513" Or Workbooks(1).Sheets(1).Cells(row1, col1 + 1).Value = "535" Or Workbooks(1).Sheets(1).Cells(row1, col1 + 1).Value = 540 Or Workbooks(1).Sheets(1).Cells(row1, col1 + 1).Value = "560") Then
Workbooks(2).Sheets(1).Cells(row2, col2).Value = Workbooks(1).Sheets(1).Cells(row1, col1).Value
Workbooks(2).Sheets(1).Cells(row2, col2 + 1).Value = Workbooks(1).Sheets(1).Cells(row1, col1 + 1).Value
Workbooks(2).Sheets(1).Cells(row2, col2 + 2).Value = Workbooks(1).Sheets(1).Cells(row1, col1 + 2).Value
Workbooks(2).Sheets(1).Cells(row2, col2 + 3).Value = Workbooks(1).Sheets(1).Cells(row1, col1 + 3).Value
Workbooks(2).Sheets(1).Cells(row2, col2 + 4).Value = Workbooks(1).Sheets(1).Cells(row1, col1 + 4).Value
Workbooks(2).Sheets(1).Cells(row2, col2 + 5).Value = Workbooks(1).Sheets(1).Cells(row1, col1 + 5).Value
Workbooks(2).Sheets(1).Cells(row2, col2 + 6).Value = Workbooks(1).Sheets(1).Cells(row1, col1 + 6).Value
Workbooks(2).Sheets(1).Cells(row2, col2 + 7).Value = Workbooks(1).Sheets(1).Cells(row1, col1 + 7).Value
row2=row2+1
End If
row1 = row1 + 1
Wend
End Sub