select and copy a range

[Albert Wijn]

dear reader

Could you please help me,
I have following problem;

In Workbook "A" sheet1 cell B3 has a "name"

In Workbook "B" sheet1 contains in column 2 several cells corresponding "name"

I am trying already for a longer time now to create a macro with the result that all data in Workbook "B" column 1,3,5 are copied to Workbook "A".

So there should be a search function for "name" out of Workbook "A", and that find in column 2 from Workbook "B" all the corresponding cells and than copy the data from column 1,3,5 of these corresponding cell's to Workbook "A"

hope this explains my problem, could you help me?

many thanks
Albert

[Jay Petrulis]

This worked for me.

Workbook A, sheet1 is the originating sheet.
Workbook A, sheet2 is the final destination sheet.
Workbook B, sheet1 is the data sheet, where the values are found and copied.

Sub test()
Dim Wkbk1 As Workbook, Wkbk2 As Workbook
Dim origSheet As Worksheet, destSheet As Worksheet
Dim findSheet As Worksheet
Dim SourceCell
Dim lastrow1 As Long, x As Long, lastrow2 As Long
Dim acopy, ccopy, ecopy

Set Wkbk1 = Workbooks("A.xls")
Set Wkbk2 = Workbooks("B.xls")

Set origSheet = Wkbk1.Sheets("Sheet1")
Set destSheet = Wkbk1.Sheets("Sheet2")

Set findSheet = Wkbk2.Sheets("Sheet1")

With Wkbk1
With origSheet
    SourceCell = .Range("B3")
End With
End With

With Wkbk2
With findSheet
lastrow1 = .Cells(Rows.Count, "B").End(xlUp).Row
For x = 1 To lastrow1
    If .Cells(x, 2) = SourceCell Then
        With Wkbk1
        With destSheet
            lastrow2 = .Cells(Rows.Count, "A").End(xlUp).Row
                With Wkbk2
                With findSheet
                    acopy = .Cells(x, 1).Value
                    ccopy = .Cells(x, 3).Value
                    ecopy = .Cells(x, 5).Value
                End With
                End With
            .Cells(lastrow2 + 1, 1) = acopy
            .Cells(lastrow2 + 1, 3) = ccopy
            .Cells(lastrow2 + 1, 5) = ecopy
        End With
        End With
    
    End If
       
Next x
End With
End With
MsgBox "Done!"
End Sub

It copies columns 1,3,5 of any found value in column 2 to A.xls sheet2, columns 1,3,and 5 respectively.

Let us know how this works out. If you want the entries to go elsewhere, please be specific and I or somebody else will adjust them

Bye,
Jay

[Mark O'Brien]

Nice piece of code Jay. The "with"'s gave me a headache though.

[Jay Petrulis]

On 2002-05-07 15:31, Mark O'Brien wrote:
Nice piece of code Jay. The "with"'s gave me a headache though.

Thanks! No kidding on the headache part. I can't see straight right now.

I tried to do this without selecting anything and the references crushed me. There has got to be an easier way to do this and not use .select or .activate, but this should be pretty fast.

Bye,
Jay

[NateO]

A different way, out of the loop (sort of...). I created a third sheet for the destination, it seemed like the source sheet already has data on it (i.e, b3 has the search term, etc....).

Sub test2()
Dim Wkbk1 As Workbook, Wkbk2 As Workbook
Dim origSheet As Worksheet, destSheet As Worksheet, srcSheet As Worksheet
Dim SourceCell, myrw As Long, myrw2 As Long
Dim mycl As Range, mycl2 As Range

Set Wkbk1 = Application.Workbooks("A")
Set Wkbk2 = Application.Workbooks("B")
Set srcSheet = Wkbk1.Sheets(1)
Set origSheet = Wkbk2.Sheets(1)
Set destSheet = Wkbk1.Sheets(2)

SourceCell = srcSheet.[b3].Value
Set mycl = origSheet.Columns("b").Find(What:=SourceCell)
If mycl Is Nothing Then GoTo 1:
myrw = mycl.Row
myrw2 = destSheet.[a65536].End(xlUp).Offset(1).Row
origSheet.Range("a" & myrw).Copy destSheet.Range("a" & myrw2)
origSheet.Range("c" & myrw).Copy destSheet.Range("c" & myrw2)
origSheet.Range("e" & myrw).Copy destSheet.Range("e" & myrw2)
again:
Set mycl2 = origSheet.Columns("b").Find(What:=SourceCell, After:=mycl)
If Not mycl2 Is Nothing Then
    If mycl2.Row > mycl.Row Then
        myrw = mycl2.Row
        myrw2 = destSheet.[a65536].End(xlUp).Offset(1).Row
        origSheet.Range("a" & myrw).Copy destSheet.Range("a" & myrw2)
        origSheet.Range("c" & myrw).Copy destSheet.Range("c" & myrw2)
        origSheet.Range("e" & myrw).Copy destSheet.Range("e" & myrw2)
        Set mycl = mycl2
        GoTo again
    End If
End If
MsgBox "Done!"
End
1: MsgBox "Could not find any cells matching cell B3."
End Sub

Have a good one y'all.

_________________
Cheers, NateO

[ This Message was edited by: NateO on 2002-05-07 17:16 ]

[Albert Wijn]

Jay

Many thanks, this is perfect. I should have asked it earlier would have safed a lot of time.

thanks, thanks

Albert