Error Checking in Excel
Thanks Thanks:  0
Likes Likes:  0
Results 1 to 6 of 6

Thread: select and copy a range

  1. #1
    New Member
    Join Date
    May 2002
    Posts
    2
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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

  2. #2
    MrExcel MVP Jay Petrulis's Avatar
    Join Date
    Mar 2002
    Location
    Chicago, IL USA
    Posts
    2,040
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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.

    Code:
    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

  3. #3
    MrExcel MVP Mark O'Brien's Avatar
    Join Date
    Feb 2002
    Location
    Columbus, OH, USA
    Posts
    3,530
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

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



  4. #4
    MrExcel MVP Jay Petrulis's Avatar
    Join Date
    Mar 2002
    Location
    Chicago, IL USA
    Posts
    2,040
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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

  5. #5
    Legend NateO's Avatar
    Join Date
    Feb 2002
    Location
    Minneapolis, Mn, USA
    Posts
    9,700
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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....).

    Code:
    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 ]

  6. #6
    New Member
    Join Date
    May 2002
    Posts
    2
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    Jay

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

    thanks, thanks

    Albert

Some videos you may like

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •