Consolidate Selected workbooks

helpexcel

Well-known Member
Joined
Oct 21, 2009
Messages
559
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!

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

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
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.

VBA 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

Well-known Member
Joined
Oct 21, 2009
Messages
559
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

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
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

Well-known Member
Joined
Oct 21, 2009
Messages
559
it only works if I select 2 workbooks. I want to have the flexibility to choose one or multiple workbooks to import from.
 

helpexcel

Well-known Member
Joined
Oct 21, 2009
Messages
559
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?
 

Watch MrExcel Video

Forum statistics

Threads
1,129,479
Messages
5,636,574
Members
416,925
Latest member
malamutus

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top