Copy/Paste Data from Multiple Workbooks Into One and Adding A Unique Identifier

jwoods29

New Member
Joined
Aug 30, 2017
Messages
10
I'm new to VBA, but have been trying to teach myself the basics. I was able to copy and paste from multiple workbooks onto on macro-enabled workbook. I need to transfer all data, even duplicated. I want a unique identifier for each of the workbooks that were pasted into my master. Here is my code:
Sub simpleXlsMerger()
Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")
'change folder path of excel files here
Set dirObj = mergeObj.Getfolder("C:\Reports")
Set filesObj = dirObj.Files
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)
'change "a2" with cell reference of start point for every files here
'for example "B3:IV" to merge all files start from from columns B and rows 3
'if you're files using more than IV column, change it to the latest column
'Also change "A" column on "A65536" to the same column as start point
Range("A2:IV" & Range("A65536").End(xlUp).Row).Copy
ThisWorkbook.Worksheets(1).Activate
'Do not change the following column. It's not the same column as above
Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
Application.CutCopyMode = False
bookList.Close
Next
End Sub
 

Some videos you may like

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.

JackDanIce

Well-known Member
Joined
Feb 3, 2010
Messages
9,696
Office Version
  1. 365
Platform
  1. Windows
Welcome to the board.

Your code is currently opening all files in C:\Reports. For each opened file, it's copying the data from A2:IVLR <lr>where LR is the last row of data on that sheet, then pasting it to the macro workbook in column A, underneath the previous file's data.

Are the files being opened .csv files? If not, you're only copying 1 sheet of data per opened file - is this correct?
What should the unique value per opened file be?
Where should this unique value go?
What happens if the number of files opened and copied is greater than that which can fit on the macro workbook worksheet, e.g. if it runs out of rows on the sheet copied to?</lr>
 
Last edited:

jwoods29

New Member
Joined
Aug 30, 2017
Messages
10
Yes, the data being copied is from a .csv file. There is roughly 45,000 lines of data in total. Is it possible to have the unique identifier the date the .csv file was created or the file name? If that cannot happen, then some string of text or integers. I would want the identifier in the last column, in this case, the column would be "T". Any help would be greatly appreciated.
 

JackDanIce

Well-known Member
Joined
Feb 3, 2010
Messages
9,696
Office Version
  1. 365
Platform
  1. Windows
This code clears all the data on the first sheet in the macro work book, then it loops through C:\Reports, opens each .csv file, copies the data and prints it to the first sheet in the macro workbook, underneath the previous file's data:
Code:
Sub ImportMerge()
    
    Dim wkb     As Workbook
    Dim wWrite  As Worksheet
    Dim FSO     As Object
    Dim Dir     As Object
    Dim obj     As Object
    
    Dim arr()   As Variant
    Dim x       As Long
    Dim y       As Long
    
    Set wWrite = Sheets(1)
    Set FSO = CreateObject("Scripting.Dictionary")
    Set Dir = FSO.getfolder("C:\Reports\")
    
    Application.ScreenUpdating = False
    
    wWrite.Cells.ClearContents
    
    For Each obj In Dir.files
        Set wkb = Workbooks.Open(obj, ReadOnly:=True)
        With wkb
            x = .Cells(.Rows.Count, 1).End(xlUp).row
            y = .Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).column
            .Cells(1, y).Resize(x).Value = .Name
            arr = .Cells(1, 1).Resize(x, y).Value
            .Close False
        End With
        Set wkb = Nothing
        
        wWrite.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
        Erase arr
    Next obj
        
    Application.ScreenUpdating = True
        
    Set wWrite = Nothing
    Set FSO = Nothing
    Set Dir = Nothing
    
End Sub
This code isn't the optimal way to read data from a closed csv file, however, try it and see how it runs for you.
 
Last edited:

jwoods29

New Member
Joined
Aug 30, 2017
Messages
10

ADVERTISEMENT

Instead of doing this for each of my clients, I've decided to run this through a database. I don't think the cell/font color at this point is prudent.
 

JackDanIce

Well-known Member
Joined
Feb 3, 2010
Messages
9,696
Office Version
  1. 365
Platform
  1. Windows
I'm afraid I do not understand your last reply and I can't see any where in this thread, mentions of cell/font colors...
 

jwoods29

New Member
Joined
Aug 30, 2017
Messages
10

ADVERTISEMENT

I keep getting a run time error 438: object doesn't support this property of method.
 

JackDanIce

Well-known Member
Joined
Feb 3, 2010
Messages
9,696
Office Version
  1. 365
Platform
  1. Windows
Try:
Code:
Sub ImportMerge()
    
    Dim wkb     As Workbook
    Dim wWrite  As Worksheet
    Dim FSO     As Object
    Dim Dir     As Object
    Dim Files   As Object
    Dim obj     As Object
    
    Dim arr()   As Variant
    Dim x       As Long
    Dim y       As Long
    
    Set wWrite = Sheets(1)
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Dir = FSO.getfolder("F:\Serious\Work\Other\Blackrock VBA Technical Exercise")
    Set Files = Dir.Files
    
    Application.ScreenUpdating = False
    
    wWrite.Cells.ClearContents
    
    For Each obj In Files
        Set wkb = Workbooks.Open(obj, ReadOnly:=True)
        With wkb
            x = .Cells(.Rows.Count, 1).End(xlUp).row
            y = .Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).column
            .Cells(1, y).Resize(x).Value = .Name
            arr = .Cells(1, 1).Resize(x, y).Value
            .Close False
        End With
        Set wkb = Nothing
        
        wWrite.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
        Erase arr
    Next obj
        
    Application.ScreenUpdating = True
        
    Set wWrite = Nothing
    Set FSO = Nothing
    Set Dir = Nothing
    Set Files = Nothing
    
End Sub
If it errors, state what line of code it errors on please.
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,122,471
Messages
5,596,342
Members
414,060
Latest member
hermanseck

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