VBA to Copy data from many workbooks to one workbook

LE_Warden · Oct 15, 2019

Hello everybody,

I just found a similar thread by fatman003 on https://www.mrexcel.com/forum/excel...data-multiple-workbooks-into-master-wkbk.html.

My problem is almost the same, but I couldn't adjust it for myself. I hope you can help me.

I have an evaluation of measurement data stored in several thousand(could the big number of files be a problem?) Excel files in a folder "C:\Users\desk\data". All have the same structure, only the number of the rows of the columns is not constant.
From all these files I would like to copy and summarize in one Excel workbook file all measured data from the

2nd column from "Time" (row 145) to the next empty cell
and from the
3rd column of "Speed" (also row 145) to the next empty cell

("Time" and "Speed" are in the same place in all Excel workbooks (in line 145), but the number of the following rows is different for each file)

The data (including "time" and "speed") from all Excel files should be listed side by side in the new file in one sheet.
All files have one sheet each.

I hope you can help me.
Thanks in advance.

Best regards from Germany
LE_Warden

=ODIN= · Oct 15, 2019

A free addin called Nutilities has a Generic Consolidator utility that can help with this http://www.iwishexcel.com/authors-favorites/generic-consolidator/

mumps · Oct 16, 2019

Try:

Code:

Sub CopyCols()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWS As Worksheet, srcWB As Workbook, LastRow As Long, lCol As Long
    Set desWS = ThisWorkbook.Sheets("Data")
    Const strPath As String = "C:\Users\desk\data\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
        Set srcWS = Sheets(1)
        With srcWS
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            lCol = desWS.Cells(1, desWS.Columns.Count).End(xlToLeft).Column + 1
            .Range("B145:C" & LastRow).Copy desWS.Cells(1, lCol)
        End With
        srcWB.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Make sure that the destination workbook where the data will be pasted has a sheet named "Data". The macro assumes all the source files have an "xlsx" extension. Also, keep in mind that the maximum number of columns in any Excel sheet is 16,384. With thousands of files, it will take the macro a little time to run.

LE_Warden · Oct 17, 2019

Hi mumps,

thank you for your help.

When I start the makro I get a message box which says that a variable is not defined. Then "strExtension =" gets marked blue and "Sub CopyCols()" yellow.

mumps · Oct 17, 2019

Try:

Code:

Sub CopyCols()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWS As Worksheet, srcWB As Workbook, LastRow As Long, lCol As Long, strextension As String
    Set desWS = ThisWorkbook.Sheets("Data")
    Const strPath As String = "C:\Users\desk\data\"
    ChDir strPath
    strextension = Dir(strPath & "*.xlsx")
    Do While strextension <> ""
        Set srcWB = Workbooks.Open(strPath & strextension)
        Set srcWS = Sheets(1)
        With srcWS
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            lCol = desWS.Cells(1, desWS.Columns.Count).End(xlToLeft).Column + 1
            .Range("B145:C" & LastRow).Copy desWS.Cells(1, lCol)
        End With
        srcWB.Close False
        strextension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

LE_Warden · Oct 17, 2019

Hi mumps,

thanks again. I can start the makro now but it does not happen what I wanted. It copies only 2 columns no matter how many files I have in the folder. And the dates in the cells aren't the same, they are melted with each other.
Ex.: left cell: 152,68798; right cell: 6,33552 --> after makro: left cell: "15268798;63" ; right cell: "3552;0"

mumps · Oct 17, 2019

I think that it would be easier to help and test possible solutions if I could work with your actual files. Perhaps you could upload copies of your destination file and at least one source file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark each file for 'Sharing' and you will be given a link to each file that you can post here. Include a detailed explanation of what you would like to do using a few examples from your data and referring to specific cells, rows, columns and worksheets. If the workbooks contain confidential information, you could replace it with generic data.

LE_Warden · Oct 20, 2019

Hi mumps,

sry for answering so late.
Here you can find 5 source files and 1 target file (how I want it looking like).

https://app.box.com/s/cvt9a1sabm8t083g8ann06hxjgor5eva

Thanks!!

mumps · Oct 20, 2019

Try:

Code:

Sub CopyCols()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWS As Worksheet, srcWB As Workbook, lCol As Long, LastNumB As Long, LastNumC As Long
    Set desWS = ThisWorkbook.Sheets("Data")
    Const strPath As String = "C:\Users\desk\data\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
        Set srcWS = Sheets(1)
        With srcWS
            lCol = desWS.Cells(1, desWS.Columns.Count).End(xlToLeft).Column + 1
            LastNumB = .Range("B" & .Rows.Count).End(xlUp).Row
            Do Until IsNumeric(Range("B" & LastNumB).Text) Or LastNumB = 1
                LastNumB = LastNumB - 1
            Loop
            LastNumC = .Range("C" & .Rows.Count).End(xlUp).Row
            Do Until IsNumeric(Range("B" & LastNumC).Text) Or LastNumC = 1
                LastNumC = LastNumC - 1
            Loop
            .Range("B50:B" & LastNumB).Copy desWS.Cells(1, lCol)
            lCol = desWS.Cells(1, desWS.Columns.Count).End(xlToLeft).Column + 1
            .Range("C50:C" & LastNumC).Copy desWS.Cells(1, lCol)
        End With
        srcWB.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

VBA to Copy data from many workbooks to one workbook

LE_Warden

New Member

Excel Facts

=ODIN=

Active Member

mumps

Well-known Member

LE_Warden

New Member

mumps

Well-known Member

LE_Warden

New Member

mumps

Well-known Member

LE_Warden

New Member

mumps

Well-known Member

Similar threads

Forum statistics

Share this page

VBA to Copy data from many workbooks to one workbook

New Member

Excel Facts

Active Member

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock