Results 1 to 2 of 2
  1. #1
    New Lounger
    Join Date
    Jan 2014
    Posts
    1
    Thanks
    1
    Thanked 0 Times in 0 Posts

    Macro to let user choose 2 different workbook, vlookup then copy data to the current workbook

    Hi,

    I have workbook1 & workbook2 with data that I need to extract into workbook3.
    Workbook 1.xlsxWorkbook 2.xlsxWorkbook 3.xlsx

    what can I do in workbook3,
    1. prompt user select workbook1, where workbook3 will vlookup data and automatically copy data into relevant cell
    2. prompt user select workbook2, where workbook3 will vloopup data and automatically copy data into relevant cell

    Your help is greatly appreciated.

    Thank you.

  2. #2
    WS Lounge VIP sdckapr's Avatar
    Join Date
    Jul 2002
    Location
    Pittsburgh, Pennsylvania, USA
    Posts
    11,225
    Thanks
    14
    Thanked 342 Times in 335 Posts
    This code in Workbook3 works with the sample files. test it on a copy...

    Code:
    Option Explicit
    Sub ChooseCopy()
      Dim wkbCopy As Workbook
      Dim wkbPaste As Workbook
      Dim wksCopy As Worksheet
      Dim wksPaste As Worksheet
      Dim sWks1 As String
      Dim sWks2 As String
      Dim sWks3 As String
      Dim sFileToOpen As String
      Dim lRowCopy As Long
      Dim lRowPaste As Long
      Dim lRowPasteStart As Long
      Dim iColPaste As Integer
      Dim lRowStart1 As Long
      Dim lRowEnd As Long
      Dim iColStart1 As Integer
      Dim iColEnd1 As Integer
      Dim iColStart2 As Integer
      Dim iColEnd2 As Integer
      
      'Change as Desired
      'info for Workbook1
      sWks1 = "Docs"
      lRowStart1 = 2  'Start of Data
      iColStart1 = 1  'Col A
      iColEnd1 = 4    'Col D
      'info for Workbook2
      sWks2 = "Report"
      iColStart2 = 2  'Col B
      iColEnd2 = 9    'Col I
      'info for Workbook3
      Set wkbPaste = ThisWorkbook
      sWks3 = "Report"
      lRowPasteStart = 3  'Start Row for pasting data
      iColPaste = 1       'Start Col for Pasting data
      Set wksPaste = wkbPaste.Worksheets(sWks3)
      
      'Choose Workbook1
      sFileToOpen = Application.GetOpenFilename
      Set wkbCopy = Workbooks.Open( _
        Filename:=sFileToOpen, _
        UpdateLinks:=0, _
        ReadOnly:=True, _
        AddToMRU:=False)
      Set wksCopy = wkbCopy.Worksheets(sWks1)
      'Copy columns from Worksheet1 into Worksheet3
      With wksCopy
        lRowEnd = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range(.Cells(lRowStart1, iColStart1), .Cells(lRowEnd, iColEnd1)).Copy _
          wksPaste.Cells(lRowPasteStart, iColPaste)
      End With
      'close workbook1
      wkbCopy.Close (False)
      
      'Choose Workbook2
      sFileToOpen = Application.GetOpenFilename
      Set wkbCopy = Workbooks.Open( _
        Filename:=sFileToOpen, _
        UpdateLinks:=0, _
        ReadOnly:=True, _
        AddToMRU:=False)
      Set wksCopy = wkbCopy.Worksheets(sWks2)
      
      'Recalc cols and get last row for Workbook3
      With wksPaste
        iColPaste = iColPaste - iColStart1 + iColEnd1 + 1
        lRowEnd = .Cells(.Rows.Count, 1).End(xlUp).Row
      End With
      With wksCopy
        For lRowPaste = lRowPasteStart To lRowEnd
          lRowCopy = 0
          On Error Resume Next
          'look for a match in Workbook2
          lRowCopy = Application.WorksheetFunction.Match( _
            wksPaste.Cells(lRowPaste, 1), .Range("A:A"), 0)
          On Error GoTo 0
          If lRowCopy <> 0 Then 'Match is found
            'Copy the cells
            .Range(.Cells(lRowCopy, iColStart2), .Cells(lRowCopy, iColEnd2)).Copy _
              wksPaste.Cells(lRowPaste, iColPaste)
          End If
        Next
      End With
      'close workbook2
      wkbCopy.Close (False)
    End Sub
    Steve

  3. The Following User Says Thank You to sdckapr For This Useful Post:

    Brannix (2014-01-10)

Posting Permissions

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