Excel 2010 Visual Basic Code for looping through files copying required data and then copying results of formulae

R

RustyHook

New Member
Joined
Apr 14, 2014
Messages
11
Hi All,

I am currently trying to Loop through a selected list of files, insert 2 rows at the top of each file then copying columns A to O out, then pasting those columns in A to O in a sheet called TK of my main work book, this sheet has a lot of complicated formulae in columns P to AV, and thus I need copy the results/values of these formulae based on the copied data all in row 2, to the next free line in another sheet called Data of my main work book. Then macro needs to close without saving and open the next file in the loop to do it all again.

All help and advise is most appreciated.

This is what I have so far, it currently loops through the files fine, but I am having trouble with copying the results of the formulae into the data sheet as well as the the inserting of rows/ the positioning of the data when it is copied over to the TK sheet (I understand that in the code I may be selecting the data to be copied over twice in two different ways, but cant get either way to work individually:

Code: 
Sub TKMAK()     
    Dim FolderPath As String, FileName As Variant
    Dim WorkBk As Workbook
    Dim SourceRange As Range, DestinationCell As Range
    Dim SelectedFiles As Variant
     
     'Set the cell where data from the first workbook will be copied to.  This cell is updated as we
     'loop through the merged workbooks
     
    Set DestinationCell = ThisWorkbook.Worksheets("TK").Range("A1")
     
     'FolderPath = "C:\Documents and Settings\lidibv0\My Documents\Metrics 2012\" ' source files location
     'ChDrive FolderPath ' Set the current directory to the the folder path.
     'ChDir FolderPath
     
     ' Use file dialog box, filter Excel files, allow multiple selections
    SelectedFiles = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
     
     'Exit immediately if user clicked Cancel
     
    If Not IsArray(SelectedFiles) Then Exit Sub
     
     'File order returned by GetOpenFilename multi-select is different to the order visible to the user, so sort the array of files
     
    Bubble_Sort_Array SelectedFiles
     
    Application.DisplayAlerts = False
     
     'Loop through the selected files
     
    For Each FileName In SelectedFiles
         
         'Open the workbook to be copied from
         
        Set WorkBk = Workbooks.Open(FileName)
        
        'Insert two rows at the top of sheet (shifting everything down by 2)
        
     Rows("1:2").Select
     Range("A2").Activate
     Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
     Columns("A:N").Select
     Range("N1").Activate


     Selection.Copy
        With WorkBk.Worksheets(1).UsedRange
            Set SourceRange = .Offset(1, 0).Resize(.Rows.Count - 1)
         
        End With
         
         'Copy source data to destination cell
         
        SourceRange.Copy DestinationCell
         
         'Update destination cell to the next available row, according to number of rows
         'in source data, ready for the next workbook to be merged
         
        Set DestinationCell = DestinationCell.Offset(SourceRange.Rows.Count)
         
         'Close the source workbook without saving changes.


         
        WorkBk.Close savechanges:=False
    
    'Copy results of formulae over to next free collumns in Data sheet
    
    ActiveWorkbook.TK.Activate
    Range("2:2").Select
    Selection.Copy
    Sheets("Data").Select
    Range("A1").Select
    Selection.End(xlDown).Select
    Selection.Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Data").Select
         
    Next
     
    Application.DisplayAlerts = True
     
End Sub
 
Private Sub Bubble_Sort_Array(theArray As Variant)
    Dim i As Integer, j As Integer, temp As Variant
    For i = LBound(theArray) To UBound(theArray) - 1
        For j = i + 1 To UBound(theArray)
            If theArray(i) > theArray(j) Then
                temp = theArray(j)
                theArray(j) = theArray(i)
                theArray(i) = temp
            End If
        Next
    Next
End Sub


Kind regards,
 
Sort by date Sort by votes
Review code for comments. Test on a copy of your data:

Code: 
Option Explicit

Sub TKMAK()

    Dim FolderPath As String, FileName As Variant
    Dim WorkBk As Workbook
    Dim SourceRange As Range, DestinationCell As Range
    Dim SelectedFiles As Variant
    Dim lLastRow As Long
    Dim lNextTKWriteRow As Long
    Dim lNextDataWriteRow As Long
    
    'Set the cell where data from the first workbook will be copied to.  This cell is updated as we
    'loop through the merged workbooks
    
    'Set DestinationCell = ThisWorkbook.Worksheets("TK").Range("A1")
    lNextTKWriteRow = 1 'Assumes no data in worksheet TK
    
    'FolderPath = "C:\Documents and Settings\lidibv0\My Documents\Metrics 2012\" ' source files location
    'ChDrive FolderPath ' Set the current directory to the the folder path.
    'ChDir FolderPath
    
    ' Use file dialog box, filter Excel files, allow multiple selections
    SelectedFiles = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
    
    'Exit if no file is selected
    If Not IsArray(SelectedFiles) Then Exit Sub
    
    'File order returned by GetOpenFilename multi-select is different to the order visible to the user, so sort the array of files
    
    Bubble_Sort_Array SelectedFiles
    
    
    'Loop through the selected files
    
    For Each FileName In SelectedFiles
    
        'Open the workbook to be copied from
        
        Set WorkBk = Workbooks.Open(FileName)
        
        'Is the data you want always on the first worksheet in the just-opened workbook?
        
        'Insert two rows at the top of sheet (shifting everything down by 2)
        Rows("1:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        
        
    '    Columns("A:N").Copy
    '    With WorkBk.Worksheets(1).UsedRange 'UsedRange may/may not end at the last populated row in your data
    '        Set SourceRange = .Offset(1, 0).Resize(.Rows.Count - 1) 'This would set from the second of the blank rows down
                                                                        'to one row below the last row of the usedrange
    '    End With
        
        With WorkBk.Worksheets(1)
            lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'last populated row in column 1 (A) of just opened workbook
            'Copy WorkBk.Worksheets(1) rows 1 through last, columns A:O to ThisWorkbook.Worksheets("TK"), lNextTKWriteRow, column 1
            .Range(.Cells(1, 1), .Cells(lLastRow, 15)).Copy ThisWorkbook.Worksheets("TK").Cells(lNextTKWriteRow, 1)
        End With
        
        'Close the source workbook without saving changes.
        Application.DisplayAlerts = False
        WorkBk.Close savechanges:=False
        Application.DisplayAlerts = True
        
        'SourceRange.Copy DestinationCell
        
        'Copy results of formulae over to next free columns in Data sheet
        
        Application.Calculate 'Ensure formulas are processed
        With Worksheets("Data")
            .Activate
            lNextDataWriteRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 'next row after last populated row in column 1 (A)
        End With
        Worksheets("TK").Range("2:2").Copy
        Cells(lNextDataWriteRow, 1).Select
        ActiveSheet.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        
'        ActiveWorkbook.TK.Activate
'        Range("2:2").Select
'        Selection.Copy
'        Sheets("Data").Select
'        Range("A1").Select
'        Selection.End(xlDown).Select
'        Selection.Offset(1, 0).Select
'        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
'            :=False, Transpose:=False
'        Sheets("Data").Select

        'As is, the code will now open the next file and APPEND its data to the TK worksheet
        'Do you want clear columns A:O on TK before bring in new data?
        
        'Update destination cell to the next available row, according to number of rows
        'in source data, ready for the next workbook to be merged
        
        'Comment/Uncomment appropriate lines
        With ThisWorkbook.Worksheets("TK")
            'Next workbook will be appended
            lNextTKWriteRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 'next row after last populated row in column 1 (A)
            
            'Clear TK data, next worksheet will not be appended
            '.Columns("A:O").ClearContents
            'lNextTKWriteRow = 1
        End With
        
    Next
    
    Application.DisplayAlerts = True
    
End Sub
 
Private Sub Bubble_Sort_Array(theArray As Variant)
    Dim i As Integer, j As Integer, temp As Variant
    For i = LBound(theArray) To UBound(theArray) - 1
        For j = i + 1 To UBound(theArray)
            If theArray(i) > theArray(j) Then
                temp = theArray(j)
                theArray(j) = theArray(i)
                theArray(i) = temp
            End If
        Next
    Next
End Sub

Option Explicit

Sub TKMAK()

    Dim FolderPath As String, FileName As Variant
    Dim WorkBk As Workbook
    Dim SourceRange As Range, DestinationCell As Range
    Dim SelectedFiles As Variant
    Dim lLastRow As Long
    Dim lNextTKWriteRow As Long
    Dim lNextDataWriteRow As Long
    
    'Set the cell where data from the first workbook will be copied to.  This cell is updated as we
    'loop through the merged workbooks
    
    'Set DestinationCell = ThisWorkbook.Worksheets("TK").Range("A1")
    lNextTKWriteRow = 1 'Assumes no data in worksheet TK
    
    'FolderPath = "C:\Documents and Settings\lidibv0\My Documents\Metrics 2012\" ' source files location
    'ChDrive FolderPath ' Set the current directory to the the folder path.
    'ChDir FolderPath
    
    ' Use file dialog box, filter Excel files, allow multiple selections
    SelectedFiles = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
    
    'Exit if no file is selected
    If Not IsArray(SelectedFiles) Then Exit Sub
    
    'File order returned by GetOpenFilename multi-select is different to the order visible to the user, so sort the array of files
    
    Bubble_Sort_Array SelectedFiles
    
    
    'Loop through the selected files
    
    For Each FileName In SelectedFiles
    
        'Open the workbook to be copied from
        
        Set WorkBk = Workbooks.Open(FileName)
        
        'Is the data you want always on the first worksheet in the just-opened workbook?
        
        'Insert two rows at the top of sheet (shifting everything down by 2)
        Rows("1:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        
        
    '    Columns("A:N").Copy
    '    With WorkBk.Worksheets(1).UsedRange 'UsedRange may/may not end at the last populated row in your data
    '        Set SourceRange = .Offset(1, 0).Resize(.Rows.Count - 1) 'This would set from the second of the blank rows down
                                                                        'to one row below the last row of the usedrange
    '    End With
        
        With WorkBk.Worksheets(1)
            lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'last populated row in column 1 (A) of just opened workbook
            'Copy WorkBk.Worksheets(1) rows 1 through last, columns A:O to ThisWorkbook.Worksheets("TK"), lNextTKWriteRow, column 1
            .Range(.Cells(1, 1), .Cells(lLastRow, 15)).Copy ThisWorkbook.Worksheets("TK").Cells(lNextTKWriteRow, 1)
        End With
        
        'Close the source workbook without saving changes.
        Application.DisplayAlerts = False
        WorkBk.Close savechanges:=False
        Application.DisplayAlerts = True
        
        'SourceRange.Copy DestinationCell
        
        'Copy results of formulae over to next free columns in Data sheet
        
        Application.Calculate 'Ensure formulas are processed
        With Worksheets("Data")
            .Activate
            lNextDataWriteRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 'next row after last populated row in column 1 (A)
        End With
        Worksheets("TK").Range("2:2").Copy
        Cells(lNextDataWriteRow, 1).Select
        ActiveSheet.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        
'        ActiveWorkbook.TK.Activate
'        Range("2:2").Select
'        Selection.Copy
'        Sheets("Data").Select
'        Range("A1").Select
'        Selection.End(xlDown).Select
'        Selection.Offset(1, 0).Select
'        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
'            :=False, Transpose:=False
'        Sheets("Data").Select

        'As is, the code will now open the next file and APPEND its data to the TK worksheet
        'Do you want clear columns A:O on TK before bring in new data?
        
        'Update destination cell to the next available row, according to number of rows
        'in source data, ready for the next workbook to be merged
        
        'Comment/Uncomment appropriate lines
        With ThisWorkbook.Worksheets("TK")
            'Next workbook will be appended
            lNextTKWriteRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 'next row after last populated row in column 1 (A)
            
            'Clear TK data, next worksheet will not be appended
            '.Columns("A:O").ClearContents
            'lNextTKWriteRow = 1
        End With
        
    Next
    
    Application.DisplayAlerts = True
    
End Sub
 
Private Sub Bubble_Sort_Array(theArray As Variant)
    Dim i As Integer, j As Integer, temp As Variant
    For i = LBound(theArray) To UBound(theArray) - 1
        For j = i + 1 To UBound(theArray)
            If theArray(i) > theArray(j) Then
                temp = theArray(j)
                theArray(j) = theArray(i)
                theArray(i) = temp
            End If
        Next
    Next
End Sub
 
Upvote 0
pbornemeirer! You are a legend of our time. It seems to work in both options you've provided up to:

Code: 
        ActiveSheet.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False

Could it be because columns A to O in copied data are blank?

The first option seems like the best to continue with as I would like to clear the columns of A:0 in TK before bringing in the new data.
 
Upvote 0
Hi Pbornemeier, you are a legend of our time!

From what I have seen the code does what it needs to up until:

Code: 
        ActiveSheet.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False

Where the results line 2:2 on the TK tab isnt populating the data tab, this may be a problem because columns A to O are blank and the data starts at column P?

I have tried both sets of code but moving forward believe the first option you've provided to delete columns A:O before copying in the next data set from the array.

The files in the array will always have just one sheet within them called "Station Report".

Kind regards,
 
Upvote 0
Hi again, changed active sheet to current selection and that seems to work fine to copy the data as values into the right place.

Now I just need to stop the appending by deleting the data in-between files and get VB to count/check column O for blank rows to past the next line.
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
Merge files and keep source formatting.
Replies
9
Views
427
Alex Blakenburg
A
A
  • Solved
Extract and Merge Files
Replies
1
Views
223
rowebca
rowebca
U
  • Question Question
Excel VBA, Loop, Copy, Loop, Paste, Autofilter, return value, Loop.
Replies
0
Views
394
user29383902
U
H
  • Solved
Amend Code to Exclude Files when dialog box Opens
Replies
2
Views
344
howard
H
L
  • Solved
Copying user selected rows to different workbook and under matching columns
Replies
5
Views
210
LaTwiglet85
L

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