Import multiple rows from another workbook

G

grabrail

Board Regular
Joined
Sep 6, 2010
Messages
128
Office Version
  1. 365
Platform
  1. Windows
OK so I have my import working sweet, for the 1 worksheet, which is just a single row of data, this cycles through multiple workbooks that are located in a specific folder and collects all the data from each one required.

However, I have a second worksheet, on each workbook, all formatted the same, including on the book im importing to. This worksheet, has multiple rows of data and could be anything from 1 to 30 rows.

I can get it to import the single row of data, within the vba that does the above part that is working. This is the code I currently have for this section where I need it to read all rows that have data and import them into my database workbook

VBA Code: 
 Workbooks("database.xlsm").Activate
       Sheets(2).Activate
       
       Sheets(2).Range("B1").Select
        'get next blank cell
            While ActiveCell.Value <> ""
                ActiveCell.Offset(1, -1).Range("B1").Select
            Wend
        'input results
   
        rowTarget = ActiveCell.Row
   
      Set wsSource = wbSource.Worksheets(7) 'EDIT IF NECESSARY
      Set wsTarget = Sheets(2)
     
      With wsTarget
         .Range("B" & rowTarget).Value = ID
         .Range("C" & rowTarget).Value = wsSource.Range("C2").Value
         .Range("D" & rowTarget).Value = wsSource.Range("D2").Value
         .Range("E" & rowTarget).Value = wsSource.Range("E2").Value
         .Range("F" & rowTarget).Value = wsSource.Range("F2").Value
       End With

wbSource and ID are declared earlier in the main code, and work as expected. But how do I wrap this section in a loop or get it to read all rows of data to import?
 

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
Sort by date Sort by votes
Hi grabrail,

in my opinion you should take a more solid way as to rely on the index of worksheets in order to set objects to them, especially when you use Sheets instead of Worksheets. I altered the way to find the next free row to write to in the target sheet.

This may work for you

VBA Code: 
Sub partOneRow()
' https://www.mrexcel.com/board/threads/import-multiple-rows-from-another-workbook.1228602/
'...
Dim wbDB As Workbook
'...

Set wbDB = Workbooks("database.xlsm")
Set wsTarget = wbDB.Worksheets(2)

Set wsSource = wbSource.Worksheets(7) 'EDIT IF NECESSARY

With wsTarget
  With .Range("B" & .Rows.Count).End(xlUp).Offset(1, 0)
    .Value = ID
    .Offset(0, 1).Resize(1, 4).Value = wsSource.Range("C2").Resize(1, 4).Value
  End With
End With

'...
Set wbDB = Nothing
End Sub

VBA Code: 
Sub partMoreRows()
' https://www.mrexcel.com/board/threads/import-multiple-rows-from-another-workbook.1228602/
'...
Dim wbDB As Workbook
'...

Set wbDB = Workbooks("database.xlsm")
Set wsTarget = wbDB.Worksheets(2)

Set wsSource = wbSource.Worksheets(7) 'EDIT IF NECESSARY
With wsSource
  Set rngCopy = .Range(.Cells(2, "C"), .Cells(.Cells(.Rows.Count, "C").End(xlUp).Row, "F"))
End With

With wsTarget
  With .Range("B" & .Rows.Count).End(xlUp).Offset(1, 0)
    .Resize(rngCopy.Rows.Count, 1).Value = ID
    .Offset(0, 1).Resize(rngCopy.Rows.Count, 4).Value = rngCopy.Value
  End With
End With

'...
Set rngCopy = Nothing
Set wbDB = Nothing
End Sub

Ciao,
Holger
 
Upvote 0
Ah sorry I should mention the ID is not set in the oringal workbook, it is being set as the data is imported in, so the first part of my code imports the data in one row from the original workbook from column B onwards, the ID is then set by the code and put in column A.

When this part of the code imports the multiple rows, to a different worksheet, the ID is set to match the ID od the first import.

So there is no ID to reference in the data that is being imported
 
Upvote 0
Hi grabrail,

the whole code would have expained that - can you agree on that? Working with parts is problematic but my procedures reflect what I understood from the description and the part of code you posted.

Holger
 
Upvote 0
Here is the complete code, you can see the bit where i am trying to make it loop over multiple rows in the source file near the end

VBA Code: 
Public Sub ImportWorksheets()
   Const FOLDER_PATH = "D:\Documents\lmg\VI Sheet\Final\Database\import\"  'REMEMBER END BACKSLASH
   
   
   '=============================================
   'Process all Excel files in specified folder
   '=============================================
   Dim sFile As String
   Dim wbTarget As Workbook
   Dim wsTarget As Worksheet
   Dim wbSource As Workbook
   Dim wsSource As Worksheet
   Dim wlSource As Worksheet
   Dim rowTarget As Long         'output row
   Dim ID As Integer
   
    Sheets(1).Range("B1").Select
        'get next blank cell
            While ActiveCell.Value <> ""
                ActiveCell.Offset(1, -1).Range("B1").Select
            Wend
        'input results
   
   rowTarget = ActiveCell.Row
   
   'check the folder exists
   If Not FileFolderExists(FOLDER_PATH) Then
      MsgBox "Specified folder does not exist, exiting!"
      Exit Sub
   End If
   
   'reset application settings in event of error
   'On Error GoTo errHandler
   Application.ScreenUpdating = False
   
   'set up the target worksheet
   Set wsTarget = Sheets(1)
   
   'loop through the Excel files in the folder
   sFile = Dir(FOLDER_PATH & "*.xlsm*")
   Do Until sFile = ""
        Sheets(1).Activate
        'Set wsSource = wbSource.Worksheets(6) 'EDIT IF NECESSARY
        Set wsTarget = Sheets(1)
      
      'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
      Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
      Set wsSource = wbSource.Worksheets(6) 'EDIT IF NECESSARY
      
      
      'import the data
      ID = rowTarget - 1
      
      With wsTarget
      
         .Range("A" & rowTarget).Value = ID
         .Range("B" & rowTarget).Value = wsSource.Range("B2").Value
         .Range("C" & rowTarget).Value = wsSource.Range("C2").Value
         .Range("D" & rowTarget).Value = wsSource.Range("D2").Value
         .Range("E" & rowTarget).Value = wsSource.Range("E2").Value
         .Range("F" & rowTarget).Value = wsSource.Range("F2").Value
         .Range("G" & rowTarget).Value = wsSource.Range("G2").Value
         .Range("H" & rowTarget).Value = wsSource.Range("H2").Value
         .Range("I" & rowTarget).Value = wsSource.Range("I2").Value
         .Range("J" & rowTarget).Value = wsSource.Range("J2").Value
         .Range("K" & rowTarget).Value = wsSource.Range("K2").Value
         .Range("L" & rowTarget).Value = wsSource.Range("L2").Value
         .Range("M" & rowTarget).Value = wsSource.Range("M2").Value
         .Range("N" & rowTarget).Value = wsSource.Range("N2").Value
         .Range("O" & rowTarget).Value = wsSource.Range("O2").Value
         .Range("P" & rowTarget).Value = wsSource.Range("P2").Value
         .Range("Q" & rowTarget).Value = wsSource.Range("Q2").Value
         .Range("R" & rowTarget).Value = wsSource.Range("R2").Value
         .Range("S" & rowTarget).Value = wsSource.Range("S2").Value
         .Range("T" & rowTarget).Value = wsSource.Range("T2").Value
         .Range("U" & rowTarget).Value = wsSource.Range("U2").Value
         .Range("V" & rowTarget).Value = wsSource.Range("V2").Value
         .Range("W" & rowTarget).Value = wsSource.Range("W2").Value
         .Range("X" & rowTarget).Value = wsSource.Range("X2").Value
         .Range("Y" & rowTarget).Value = wsSource.Range("Y2").Value
         .Range("Z" & rowTarget).Value = wsSource.Range("Z2").Value
         .Range("AA" & rowTarget).Value = wsSource.Range("AA2").Value
         .Range("AB" & rowTarget).Value = wsSource.Range("AB2").Value
         .Range("AC" & rowTarget).Value = wsSource.Range("AC2").Value
         .Range("AD" & rowTarget).Value = wsSource.Range("AD2").Value
         .Range("AE" & rowTarget).Value = wsSource.Range("AE2").Value
         .Range("AF" & rowTarget).Value = wsSource.Range("AF2").Value
         .Range("AG" & rowTarget).Value = wsSource.Range("AG2").Value
         .Range("AH" & rowTarget).Value = wsSource.Range("AH2").Value
         .Range("AI" & rowTarget).Value = wsSource.Range("AI2").Value
         .Range("AJ" & rowTarget).Value = wsSource.Range("AJ2").Value
         .Range("AK" & rowTarget).Value = wsSource.Range("AK2").Value
         .Range("AL" & rowTarget).Value = wsSource.Range("AL2").Value
         .Range("AM" & rowTarget).Value = wsSource.Range("AM2").Value
         .Range("AN" & rowTarget).Value = wsSource.Range("AN2").Value
         .Range("AO" & rowTarget).Value = wsSource.Range("AO2").Value
          
            
            
         'optional source filename in the last column
         '.Range("N" & rowTarget).Value = sFile
      End With
      
       Workbooks("database.xlsm").Activate
       Sheets(2).Activate
       
       Sheets(2).Range("B1").Select
        'get next blank cell
            While ActiveCell.Value <> ""
                ActiveCell.Offset(1, -1).Range("B1").Select
            Wend
        'input results
   
        rowTarget = ActiveCell.Row
   
      Set wsSource = wbSource.Worksheets(7) 'EDIT IF NECESSARY
      Set wsTarget = Sheets(2)
      
      
 
      
      With wsTarget
         .Range("B" & rowTarget).Value = ID
         .Range("C" & rowTarget).Value = wsSource.Range("C2").Value
         .Range("D" & rowTarget).Value = wsSource.Range("D2").Value
         .Range("E" & rowTarget).Value = wsSource.Range("E2").Value
         .Range("F" & rowTarget).Value = wsSource.Range("F2").Value
       End With
      
      'close the source workbook, increment the output row and get the next file
      wbSource.Close SaveChanges:=False
      rowTarget = rowTarget + 1
      sFile = Dir()
   Loop
   

   
errHandler:
   'On Error Resume Next
   'Application.ScreenUpdating = True
   
   'tidy up
   Set wsSource = Nothing
   Set wbSource = Nothing
   Set wsTarget = Nothing
End Sub

Private Function FileFolderExists(strPath As String) As Boolean
    If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function
 
Upvote 0
Hi grabrail,

as I have stated before I would not rely on the Index number to identify certain sheets inside a workbook. As the sheetname may be altered easily I mostly rely on the codename of the sheets and set the objects to those if they are in any other workbook than the workbook with code as in that I can work with the codename directly without setting an object to them. And I use Worksheets instead of Sheets.

I assumed that workbook database.xlsm is the target for any copy, if not the code must be amended to suit. And I altered the search criteria for files from xlsm* to xls*. A test with the import of just 2 workbooks ran fine.

In case of any error (and if you have any questions regarding the code) please post and give up error number and codeline that failed, I'll try to fix ASAP:

VBA Code: 
Public Sub ImportWorksheets()
' https://www.mrexcel.com/board/threads/import-multiple-rows-from-another-workbook.1228602/
  
  '=============================================
  'Process all Excel files in specified folder
  '=============================================
  Dim lngLRowSrc As Long
  Dim lngCounter As Long
  
  Dim rngTargSh1 As Range       'object holding reference to the first empty cell in Target Column B
  Dim rngTargSh2 As Range
  Dim rngSource As Range
  
  Dim sFile As String
  
  Dim wbDB As Workbook
  Dim wbSource As Workbook
  
  Dim wsTargSh1 As Worksheet
  Dim wsTargSh2 As Worksheet
  Dim wsSource As Worksheet
  
  Const FOLDER_PATH As String = "D:\Documents\lmg\VI Sheet\Final\Database\import\"  'REMEMBER END BACKSLASH
  
  '/// I strongly recommend not to rely on the index numbers of sheets!!!
  '/// If so use Worksheets instead of Sheets
  '/// In any case a check for the opened workbooks should be included
  '/// that these have at least 7 worksheets but I would include any other check
  '/// on either the name of the sheets (even partly) or the contents to be of a certain nature
  '/// as I find it hard to just guess the worksheets in the workbooks will be in the order needed
  
'  '/// these constants will lead to search for any sheet being named as the constants
'  Const cstrShTarg1 As String = "1"
'  Const cstrShTarg2 As String = "2"
'
'  Const cstrShSrc6 As String = "6"
'  Const cstrshSrc7 As String = "7"
    
  'check the folder exists
  If Not FileFolderExists(FOLDER_PATH) Then
    MsgBox "Specified folder does not exist, exiting!"
    Exit Sub
  End If
  
  '/// assuming this is the workbook where data will be collected
  Set wbDB = Workbooks("database.xlsm")
  
  'set up the target worksheet
  Set wsTargSh1 = wbDB.Worksheets(1)
  '/// setting an object to the first empty cell in Column B
  With wsTargSh1
    Set rngTargSh1 = .Range("B" & .Rows.Count).End(xlUp).Offset(1, 0)
  End With
  
  Set wsTargSh2 = wbDB.Worksheets(2)
  With wsTargSh2
    Set rngTargSh2 = .Range("B" & .Rows.Count).End(xlUp).Offset(1, 0)
  End With
  
  'reset application settings in event of error
  Application.ScreenUpdating = False
  
  'loop through the Excel files in the folder
  sFile = Dir(FOLDER_PATH & "*.xls*")
  Do Until sFile = ""
     
    'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
    Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
    Set wsSource = wbSource.Worksheets(6) 'EDIT IF NECESSARY
         
    With rngTargSh1
      .Offset(0, -1).Value = .Row - 1
      .Resize(1, 40).Value = wsSource.Range("B2").Resize(1, 40).Value
    ''      'optional source filename in the last column
    ''      .Offset(0, 41).Value = sFile
    End With
     
    Set wsSource = wbSource.Worksheets(7) 'EDIT IF NECESSARY
    'using a loop to cover all rows from the source sheet
    With wsSource
      lngLRowSrc = .Cells(.Rows.Count, "C").End(xlUp).Row
    End With
    For lngCounter = 2 To lngLRowSrc
      With rngTargSh2
        With .Offset(lngCounter - 2, -1)
          .FormulaR1C1 = "=ROW()-1"
          .Value = .Value
        End With
        .Offset(lngCounter - 2, 0).Resize(1, 4).Value = wsSource.Range("C" & lngCounter).Resize(1, 40).Value
      End With
    Next lngCounter
    Set rngTargSh2 = wsTargSh2.Range("B" & wsTargSh2.Rows.Count).End(xlUp).Offset(1, 0)
    
'    'building a range and copy values
'    With wsSource
'      If .Cells(.Rows.Count, "C").End(xlUp).Row Then
'        Set rngSource = .Range("C2", .Cells(.Cells(.Rows.Count, "C").End(xlUp).Row, "F"))
'      End If
'    End With
'    If Not rngSource Is Nothing Then
'      With rngTargSh2
'        With .Resize(rngSource.Rows.Count, 1)
'          .FormulaR1C1 = "=ROW()-1"
'          .Value = .Value
'        End With
'        .Offset(0, 1).Resize(rngSource.Rows.Count, 4).Value = rngSource
'      End With
'      Set rngTargSh2 = wsTargSh2.Range("B" & wsTargSh2.Rows.Count).End(xlUp).Offset(1, 0)
'    End If
    
    'close the source workbook, increment the output row and get the next file
    wbSource.Close SaveChanges:=False
    Set rngTargSh1 = rngTargSh1.Offset(1, 0)
    sFile = Dir()
  Loop
  
end_here:
  Application.ScreenUpdating = True
  
  'tidy up
  Set rngSource = Nothing
  Set rngTargSh2 = Nothing
  Set rngTargSh1 = Nothing
  Set wsTargSh2 = Nothing
  Set wsTargSh1 = Nothing
  Set wsSource = Nothing
  Set wbSource = Nothing
  Set wbDB = Nothing
End Sub

Private Function FileFolderExists(strPath As String) As Boolean
    If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function

Ciao,
Holger
 
Upvote 0
Hi, this works great, thank you. The source sheets cannot be ammended in anyway, they are locked in to what is needed.

I am however having a couple of small issues with this import.

On the sheet(2) of the target it is inserting 2 empty rows with just an id in them, and also, the data from columb B to F is one step to the left, e.g. the serviceabale column should be the data that is in the IM No column, the IM No data is missing, as per the table below

Inspection IDIM NoServiceableDefect TextOCRS ScoreSource
1​
Sworn
0​
DPU
2​
DPffefe
100​
VIO
3​
Sworn
0​
DPU
4​
DPffefe
100​
VIO
5​
Sworn
0​
DPU
6​
DPffefe
100​
VIO
7​
Sworn
0​
DPU
8​
DPffefe
100​
VIO
9​
10​

 
Upvote 0
Ok Fixed the Missing Data

Changed

VBA Code: 
.Offset(lngCounter - 2, 0).Resize(1, 4).Value = wsSource.Range("C" & lngCounter).Resize(1, 40).Value


To

VBA Code: 
.Offset(lngCounter - 2, 0).Resize(1, 4).Value = wsSource.Range("B" & lngCounter).Resize(1, 40).Value

still getting 2 empty rows added to the end, but cant figure why

Actually looking at it, the ID on the sheets(2) worksheet needs to tally up with the id on the sheets(1) worksheet, so instead of each row on sheets(2) having a unique ID, I need each row from from the same file to have the same ID as the single row imported from that file on Sheets(1)
 
Last edited:
Upvote 0
ignore it, rogue hidden data in source file, now deleted and works perfectly. thank you for your help
 
Upvote 0
Hi grabrail,

your original code for the part you corrected was

VBA Code: 
      Set wsSource = wbSource.Worksheets(7) 'EDIT IF NECESSARY
      Set wsTarget = Sheets(2)
      With wsTarget
         .Range("B" & rowTarget).Value = ID
         .Range("C" & rowTarget).Value = wsSource.Range("C2").Value
         .Range("D" & rowTarget).Value = wsSource.Range("D2").Value
         .Range("E" & rowTarget).Value = wsSource.Range("E2").Value
         .Range("F" & rowTarget).Value = wsSource.Range("F2").Value
       End With

I mixed things up (sorry) but the part in question should be

Rich (BB code): 
    Set wsSource = wbSource.Worksheets(7) 'EDIT IF NECESSARY
    'using a loop to cover all rows from the source sheet
    With wsSource
      lngLRowSrc = .Cells(.Rows.Count, "C").End(xlUp).Row
    End With
    For lngCounter = 2 To lngLRowSrc
      With rngTargSh2
        With .Offset(lngCounter - 2, 0)
          .FormulaR1C1 = "=ROW()-1"
          .Value = .Value
        End With
        .Offset(lngCounter - 2, 1).Resize(1, 4).Value = wsSource.Range("C" & lngCounter).Resize(1, 4).Value
      End With
    Next lngCounter
    Set rngTargSh2 = wsTargSh2.Range("B" & wsTargSh2.Rows.Count).End(xlUp).Offset(1, 0)

I would have suggested blanks or imprintable characters to be the reason for the empty rows, glad you got it solved by yourself.

Holger
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Question
Copy from multiple worksheets and multiple source files in a folder and paste into multiple sheets in target workbook
Replies
0
Views
486
Hs72711
H
G
  • Solved
Data Import stopping after 16 rows
Replies
2
Views
343
grabrail
G
A
  • Solved
Help with macros to open many files, and extract data. Need help with match / find.
Replies
9
Views
965
johnnyL
J
C
  • Question
Finding any two values in each cell text in a column of cells with both values as one Textbox1 variable
2
Replies
10
Views
229
chazrab
C
J
  • Solved
Copy and Paste
2
Replies
14
Views
753
Anthony47
A

Forum statistics

Threads
1,215,004
Messages
6,122,659
Members
449,091
Latest member
peppernaut

Share this page

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
Back
Top