I need to consolidate specific cells of multiple workbooks into one table in Excel

asked 2018-03-31 18:43:55 +0100

this post is marked as community wiki

This post is a wiki. Anyone with karma >75 is welcome to improve it.

Hi all, I found this code that does most of the work, but it copies the whole workbook data. All I need is to target specific cell ranges (such as A2 and A10 and A14:D14 and A22) from the target workbooks and add the data inside the table of the destination worksheet. All the target workbooks are inside one folder and named in sequence (1.csv, 2.csv, etc):

Option Explicit
Sub CombineDataFiles()

Dim DataBook As Workbook, OutBook As Workbook
Dim DataSheet As Worksheet, OutSheet As Worksheet
Dim TargetFiles As FileDialog
Dim MaxNumberFiles As Long, FileIdx As Long, _
    LastDataRow As Long, LastDataCol As Long, _
    HeaderRow As Long, LastOutRow As Long
Dim DataRng As Range, OutRng As Range

'initialize constants'
MaxNumberFiles = 2001
HeaderRow = 1 'assume headers are always in row 1'
LastOutRow = 1

'prompt user to select files'
Set TargetFiles = Application.FileDialog(msoFileDialogOpen)
With TargetFiles
    .AllowMultiSelect = True
    .Title = "Multi-select target data files:"
    .ButtonName = ""
    .Filters.Add ".csv files", "*.csv"
End With

'error trap - do not allow user to pick more than 2000 files'
If TargetFiles.SelectedItems.Count > MaxNumberFiles Then
    MsgBox ("Too many files selected, please pick more than " & 
MaxNumberFiles & ". Exiting sub...")
    Exit Sub
End If

'set up the output workbook'
Set OutBook = Workbooks.Add
Set OutSheet = OutBook.Sheets(1)

'loop through all files'
For FileIdx = 1 To TargetFiles.SelectedItems.Count

    'open the file and assign the workbook/worksheet'
    Set DataBook = Workbooks.Open(TargetFiles.SelectedItems(FileIdx))
    Set DataSheet = DataBook.ActiveSheet

    'identify row/column boundaries'
    LastDataRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, 
    LastDataCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, 

    'if this is the first go-round, include the header'
    If FileIdx = 1 Then
        Set DataRng = Range(DataSheet.Cells(HeaderRow, 1), 
DataSheet.Cells(LastDataRow, LastDataCol))
        Set OutRng = Range(OutSheet.Cells(HeaderRow, 1), 
OutSheet.Cells(LastDataRow, LastDataCol))
    'if this is NOT the first go-round, then skip the header'
        Set DataRng = Range(DataSheet.Cells(HeaderRow + 1, 1), 
DataSheet.Cells(LastDataRow, LastDataCol))
        Set OutRng = Range(OutSheet.Cells(LastOutRow + 1, 1), 
OutSheet.Cells(LastOutRow + 1 + LastDataRow, LastDataCol))
    End If

    'copy the data to the outbook'
    DataRng.Copy OutRng

    'close the data book without saving'
    DataBook.Close False

    'update the last outbook row'
    LastOutRow = OutSheet.Cells.Find("*", SearchOrder:=xlByRows, 

Next FileIdx

'let the user know we are done!'
MsgBox ("Combined " & TargetFiles.SelectedItems.Count & " files!")

End Sub
edit retag flag offensive close merge delete



And what does it have to do with LibreOffice?

gabix gravatar imagegabix ( 2018-03-31 18:48:43 +0100 )edit

Yes, really: the code is VBA. Also - please don't ask as wikis here.

Mike Kaganski gravatar imageMike Kaganski ( 2018-03-31 18:55:23 +0100 )edit