Consolidate Selected workbooks

[helpexcel]

Hi - I have a long code, that basically allows the user to select the workbooks to copy and then pastes the data in another workbook. What I'm wondering, is there a way to condense the code? Is there a way to alter the code so that it will work whether you select 1,2..5 workbooks? Right now, it only works if you select 2 workbooks.

Thanks!

Dim N1 As String, N2 As String
Dim x As Long
    With ListBox1
        For x = 0 To .ListCount - 1
            If .Selected(x) = True Then
                If N2 <> "" Then Exit For
                If N1 = "" Then N1 = .List(x) Else N2 = .List(x)
                .Selected(x) = False
            End If
        Next
    End With
    
Dim wb1, wb2 As Workbook
Dim ws1, ws2, ws3, wsSP As Worksheet
Dim LR, lr2, lr3 As Long
Dim Cl As Range
sName = "Yahoo"
  
   Set wb1 = Workbooks(N1)
   Set wb2 = Workbooks(N2)
          
    Set wsSP = Sheet1
    Set ws1 = Sheet3
    
    Set ws2 = wb1.Sheets(sName)
    Set ws3 = wb2.Sheets(sName)
    
With ws1
    If IsEmpty(.Range("A11")) = True Then
        lr2 = 11
    Else
        lr2 = .Cells(.Rows.Count, "A").End(xlUp).Row
    End If

'    If IsEmpty(.Range("A11")) = False Then
'        .Range("A11:Y" & lr2).ClearContents
'    End If
End With
 
With ws2
    LR = .Cells(.Rows.Count, "C").End(xlUp).Row - 2
    .Range("C11:C" & LR).Copy
    ws1.Range("A11").PasteSpecial xlPasteValues
End With
      
With ws3
    lr3 = .Cells(.Rows.Count, "C").End(xlUp).Row - 2
    .Range("C11:C" & lr3).Copy
    ws1.Range("A" & Rows.Count).End(xlUp).PasteSpecial xlPasteValues
End With

    With CreateObject("scripting.dictionary")
      .CompareMode = 1
        For Each Cl In ws2.Range("C11" & LR)
         .Item(Cl.Value) = Cl.Offset(, 15).Value
        Next Cl
        For Each Cl In ws3.Range("C11" & lr3)
        If Not .exists(Cl.Value) Then .Add Cl.Value, Cl.Offset(, 15).Value
        Next Cl
        For Each Cl In ws1.Range("A11" & lr2)
        If .exists(Cl.Value) Then Cl.Offset(, 13).Value = .Item(Cl.Value)
        Next Cl
        If .Count > 0 Then ws1.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(.Count).Value = Application.Transpose(.keys)
    End With
    
    With CreateObject("scripting.dictionary")
      .CompareMode = 1
        For Each Cl In ws2.Range("C11", ws2.Range("E" & Rows.Count).End(xlUp))
         .Item(Cl.Value) = Cl.Offset(, 3).Value
        Next Cl
        For Each Cl In ws3.Range("C11", ws3.Range("E" & Rows.Count).End(xlUp))
        If Not .exists(Cl.Value) Then .Add Cl.Value, Cl.Offset(, 3).Value
        Next Cl
        For Each Cl In ws1.Range("A11", ws1.Range("A" & Rows.Count).End(xlUp))
         Cl.Offset(, 1).Value = .Item(Cl.Value)
         Next Cl
    End With

    With CreateObject("scripting.dictionary")
      .CompareMode = 1
        For Each Cl In ws2.Range("C11", ws2.Range("E" & Rows.Count).End(xlUp))
         .Item(Cl.Value) = Cl.Offset(, 14).Value
        Next Cl
        For Each Cl In ws3.Range("C11", ws3.Range("E" & Rows.Count).End(xlUp))
        If Not .exists(Cl.Value) Then .Add Cl.Value, Cl.Offset(, 14).Value
        Next Cl
        For Each Cl In ws1.Range("A11", ws1.Range("A" & Rows.Count).End(xlUp))
         Cl.Offset(, 8).Value = .Item(Cl.Value)
        Next Cl
    End With

    With CreateObject("scripting.dictionary")
      .CompareMode = 1
        For Each Cl In ws2.Range("C11", ws2.Range("E" & Rows.Count).End(xlUp))
         .Item(Cl.Value) = Cl.Offset(, 9).Value
        Next Cl
        For Each Cl In ws3.Range("C11", ws3.Range("E" & Rows.Count).End(xlUp))
        If Not .exists(Cl.Value) Then .Add Cl.Value, Cl.Offset(, 9).Value
        Next Cl
        For Each Cl In ws1.Range("A11", ws1.Range("A" & Rows.Count).End(xlUp))
         Cl.Offset(, 6).Value = .Item(Cl.Value)
        Next Cl
    End With

    With CreateObject("scripting.dictionary")
      .CompareMode = 1
        For Each Cl In ws2.Range("C11", ws2.Range("E" & Rows.Count).End(xlUp))
         .Item(Cl.Value) = Cl.Offset(, 10).Value
        Next Cl
        For Each Cl In ws3.Range("C11", ws3.Range("E" & Rows.Count).End(xlUp))
        If Not .exists(Cl.Value) Then .Add Cl.Value, Cl.Offset(, 10).Value
        Next Cl
        For Each Cl In ws1.Range("A11", ws1.Range("A" & Rows.Count).End(xlUp))
         Cl.Offset(, 7).Value = .Item(Cl.Value)
        Next Cl
    End With

    With CreateObject("scripting.dictionary")
      .CompareMode = 1
        For Each Cl In ws2.Range("C11", ws2.Range("E" & Rows.Count).End(xlUp))
         .Item(Cl.Value) = Cl.Offset(, 16).Value
        Next Cl
        For Each Cl In ws3.Range("C11", ws3.Range("E" & Rows.Count).End(xlUp))
        If Not .exists(Cl.Value) Then .Add Cl.Value, Cl.Offset(, 16).Value
        Next Cl
        For Each Cl In ws1.Range("A11", ws1.Range("A" & Rows.Count).End(xlUp))
         Cl.Offset(, 9).Value = .Item(Cl.Value)
        Next Cl
    End With

    With CreateObject("scripting.dictionary")
      .CompareMode = 1
        For Each Cl In ws2.Range("C11", ws2.Range("E" & Rows.Count).End(xlUp))
         .Item(Cl.Value) = Cl.Offset(, 8).Value
        Next Cl
        For Each Cl In ws3.Range("C11", ws3.Range("E" & Rows.Count).End(xlUp))
        If Not .exists(Cl.Value) Then .Add Cl.Value, Cl.Offset(, 8).Value
        Next Cl
        For Each Cl In ws1.Range("A11", ws1.Range("A" & Rows.Count).End(xlUp))
         Cl.Offset(, 4).Value = .Item(Cl.Value)
        Next Cl
    End With

    With CreateObject("scripting.dictionary")
      .CompareMode = 1
        For Each Cl In ws2.Range("C11", ws2.Range("E" & Rows.Count).End(xlUp))
         .Item(Cl.Value) = Cl.Offset(, 6).Value
        Next Cl
        For Each Cl In ws3.Range("C11", ws3.Range("E" & Rows.Count).End(xlUp))
        If Not .exists(Cl.Value) Then .Add Cl.Value, Cl.Offset(, 6).Value
        Next Cl
        For Each Cl In ws1.Range("A11", ws1.Range("A" & Rows.Count).End(xlUp))
         Cl.Offset(, 18).Value = .Item(Cl.Value)
        Next Cl
    End With

    With CreateObject("scripting.dictionary")
      .CompareMode = 1
        For Each Cl In ws2.Range("C11", ws2.Range("C" & Rows.Count).End(xlUp))
         .Item(Cl.Value) = Cl.Offset(, 7).Value
        Next Cl
        For Each Cl In ws3.Range("C11", ws3.Range("C" & Rows.Count).End(xlUp))
        If Not .exists(Cl.Value) Then .Add Cl.Value, Cl.Offset(, 7).Value
        Next Cl
        For Each Cl In ws1.Range("A11", ws1.Range("A" & Rows.Count).End(xlUp))
         Cl.Offset(, 2).Value = .Item(Cl.Value)
        Next Cl
    End With

 

[JLGWhiz]

He is some generic code that would allow access to all workbooks in a folder. Comments in green are to assist in determining how and where to modify the code.

Sub t()
Dim fPath As String, fName As String, wb As Workbook, sh As Worksheet
fPath = ThisWorkbook.Path & "\" 'If target files are in same directory, else directory path for target files.
Set sh = ThisWorkbook.ActiveSheet 'assumes workbook open to destination or source sheet as case applies.
fName = Dir(fPath & "*.xls*") 'Dir funcion to make array of workbooks in folder with .xls* file extension.
    Do While fName <> ""  'initialize Do loop
        If fName <> ThisWorkbook.Name Then  'skip the host workbook when in same folder
            Set wb = Workbooks.Open(fPath & fName)  'Opens workbooks in array one at a time
            wb.Sheets(1).Range("A1:D10").Copy sh.Cells(Rows.Count, 1).End(xlUp)(2) 'copies range to host wb.
            'The line above can be modified to need by changing sheet number or name and range.  It can
            'also change the destination coding to a different column, e.g. (Rows.Count, 2),
            'There migh be other actions a user wants to take and they would be done here.
            wb.Close False
        End If
        fName = Dir 'Get new file name
    Loop  'Increment loop
End Sub

It is many times easier to write new code than to modify someone else's that was written for a different purpose. You should state your objective, what you want to do, where the files are located if not all in the ame folder and any sheet names that are involved in copying and pasting or other transactional events.

 

[helpexcel]

Sorry, fair point. The code pulls up a list box where you can select the workbooks you want to import data from. It then looks for the sheets named “yahoo” and copies all the data in column c to column a of the current workbook/sheet. It then looks at column A and does a vlookup in the other 2 sheets to populate the rest of the data.

 

[JLGWhiz]

If the current code is producing desired results in a reasonable length of time, I would stick with it. A quick look tells me that you have a comples worksheet that data is extracted from and pasted to, so maybe you don't want to mess with a working procedure.

 

[helpexcel]

it only works if I select 2 workbooks. I want to have the flexibility to choose one or multiple workbooks to import from.

 

[helpexcel]

is there a way to write the code so that for each ws selected in the listbox, the values in columns C, and the other columns in the code are copied to current worksheet?