Help - VBA Copy Non-Contiguos cells and Paste to specific cells in another workbook.

Fretflyer

New Member
Joined
Oct 3, 2012
Messages
8
Thanks to Ron De Bruin for this wonderful code. I copy/pasted it and have been hacking at it here and there to try and make it fit my situation. I have limited experience with VBA so please forgive my butchering of this.

I would like to set the source cells (which are non-contiguos) and paste them in the worksheet (in a location differening from the cell address in the source).

I would also like the pasted values to be pasted across the row rather than down the column.

I changed RDB's code to paste directly to active worksheet rather than create a new one. I have also changed source cells.

Any help much appreciated.


Code:
'You can copy the code portions in the same modules as I have done in the example workbook
'but it will also work if you copy the whole txt file in one module
'Ron de Bruin, 20 July 2008
'http://www.rondebruin.nl/fso.htm
 
'*************************************************************
'****This portion goes in a module named Basic_Code_Module****
'*************************************************************

Private myFiles() As String
Private Fnum As Long
Function Get_File_Names(MyPath As String, Subfolders As Boolean, _
                        ExtStr As String, myReturnedFiles As Variant) As Long
    Dim Fso_Obj As Object, RootFolder As Object
    Dim SubFolderInRoot As Object, file As Object
    'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If
    'Create FileSystemObject object
    Set Fso_Obj = CreateObject("Scripting.FileSystemObject")
    Erase myFiles()
    Fnum = 0
    'Test if the folder exist and set RootFolder
    If Fso_Obj.FolderExists(MyPath) = False Then
        Exit Function
    End If
    Set RootFolder = Fso_Obj.GetFolder(MyPath)
    'Fill the array(myFiles)with the list of Excel files in the folder(s)
    'Loop through the files in the RootFolder
    For Each file In RootFolder.Files
        If LCase(file.Name) Like LCase(ExtStr) Then
            Fnum = Fnum + 1
            ReDim Preserve myFiles(1 To Fnum)
            myFiles(Fnum) = MyPath & file.Name
        End If
    Next file
    'Loop through the files in the Sub Folders if SubFolders = True
    If Subfolders Then
        Call ListFilesInSubfolders(OfFolder:=RootFolder, FileExt:=ExtStr)
    End If
    myReturnedFiles = myFiles
    Get_File_Names = Fnum
End Function

Sub ListFilesInSubfolders(OfFolder As Object, FileExt As String)
'Origenal SubFolder code from Chip Pearson
'http://www.cpearson.com/Excel/RecursionAndFSO.htm
'Changed by Ron de Bruin, 27-March-2008
    Dim SubFolder As Object
    Dim fileInSubfolder As Object
    For Each SubFolder In OfFolder.Subfolders
        ListFilesInSubfolders OfFolder:=SubFolder, FileExt:=FileExt
        For Each fileInSubfolder In SubFolder.Files
            If LCase(fileInSubfolder.Name) Like LCase(FileExt) Then
                Fnum = Fnum + 1
                ReDim Preserve myFiles(1 To Fnum)
                myFiles(Fnum) = SubFolder & "\" & fileInSubfolder.Name
            End If
        Next fileInSubfolder
    Next SubFolder
End Sub

Function RDB_Last(choice As Integer, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = last row
' 2 = last column
' 3 = last cell
    Dim lrw As Long
    Dim lcol As Integer
    Select Case choice
    Case 1:
        On Error Resume Next
        RDB_Last = rng.Find(What:="*", _
                            after:=rng.Cells(1), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
        On Error GoTo 0
    Case 2:
        On Error Resume Next
        RDB_Last = rng.Find(What:="*", _
                            after:=rng.Cells(1), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
        On Error GoTo 0
    Case 3:
        On Error Resume Next
        lrw = rng.Find(What:="*", _
                       after:=rng.Cells(1), _
                       Lookat:=xlPart, _
                       LookIn:=xlFormulas, _
                       SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious, _
                       MatchCase:=False).Row
        On Error GoTo 0
        On Error Resume Next
        lcol = rng.Find(What:="*", _
                        after:=rng.Cells(1), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
        On Error GoTo 0
        On Error Resume Next
        RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
        If Err.Number > 0 Then
            RDB_Last = rng.Cells(1).Address(False, False)
            Err.Clear
        End If
        On Error GoTo 0
    End Select
End Function
 

'**********************************************************
'****This portion goes in a module named Get_Data_Macro****
'**********************************************************
'The example macro below you can use to merge a fixed range or
'all cells from one or all worksheets from each workbook in a folder
'First we call the Function "Get_File_Names" to fill a array with all file names
'There are three arguments in this Function that we can change
'1) MyPath = the folder where the files are
'2) Subfolders = True if you want to include subfolders
'3) ExtStr = file extension of the files you want to merge
'   ExtStr examples are: "*.xls" , "*.csv" , "*.xlsx"
'   "*.xlsm" ,"*.xlsb" , for all Excel file formats use "*.xl*"
'   Do not change myReturnedFiles:=myFiles

'Then if there are files in the folder we call the macro "Get_Data"
'There are six arguments in this macro that we can change

'1) FileNameInA = True to add the path/file name in the A column
'2) PasteAsValues = True to paste as values (recommend)
'3) SourceShName = sheet name, if "" it will use the SourceShIndex and if "all" it copy from all worksheets
'4) SourceShIndex = to avoid problems with different sheet names use the index (1 is the first worksheet)
'5) SourceRng = Range you want to copy. Tip: "A:F" will copy all cells with data in this six columns
'6) StartCell = Enter the first cell and the macro will copy from that cell till the last cell on the worksheet
'   If StartCell = "" then it use the SourceRng
'   Do not change myReturnedFiles:=myFiles

'The example below will merge A1:G1 from the first worksheet of each file
'It will use a fixed range on the first worksheet because SourceShName and StartCell are ""
Sub RDB_Merge_Data()
    Dim myFiles As Variant
    Dim myCountOfFiles As Long
    myCountOfFiles = Get_File_Names( _
                     MyPath:="O:\Jobs\Jobs In Progress\C12008 Meridian Apartments\Other", _
                     Subfolders:=True, _
                     ExtStr:="*Form.xls", _
                     myReturnedFiles:=myFiles)
    If myCountOfFiles = 0 Then
        MsgBox "No files that match the ExtStr in this folder"
        Exit Sub
    End If
    Get_Data _
            FileNameInA:=False, _
            PasteAsValues:=True, _
            SourceShName:="Job Information", _
            SourceShIndex:=1, _
            SourceRng:="B7, B8, B9, B12", _
            StartCell:="", _
            myReturnedFiles:=myFiles
End Sub
 
' Note: You not have to change the macro below, you only
' edit and run the RDB_Merge_Data above.

Sub Get_Data(FileNameInA As Boolean, PasteAsValues As Boolean, SourceShName As String, _
             SourceShIndex As Integer, SourceRng As String, StartCell As String, myReturnedFiles As Variant)
    Dim SourceRcount As Long
    Dim SourceRange As Range, destrange As Range
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim rnum As Long, CalcMode As Long
    Dim SourceSh As Variant
    Dim sh As Worksheet
    Dim I As Long
    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    'Add a new workbook with one sheet named "Combine Sheet"
       'Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
   ' BaseWks.Name = "Summary Sheet"
    
    
    
    'BaseWks = ActiveWorkbook.Name
   ' BaseWks.Name = "Sheet 1"
    'Set start row for the Data
    rnum = 2
    'Check if we use a named sheet or the index
    If SourceShName = "" Then
        SourceSh = SourceShIndex
    Else
        SourceSh = SourceShName
    End If
    'Loop through all files in the array(myFiles)
    For I = LBound(myReturnedFiles) To UBound(myReturnedFiles)
        Set mybook = Nothing
        On Error Resume Next
        Set mybook = Workbooks.Open(myReturnedFiles(I))
        On Error GoTo 0
        If Not mybook Is Nothing Then
            If LCase(SourceShName) <> "all" Then
                'Set SourceRange and check if it is a valid range
                On Error Resume Next
                If StartCell <> "" Then
                    With mybook.Sheets(SourceSh)
                        Set SourceRange = .Range(StartCell & ":" & RDB_Last(3, .Cells))
                        'Test if the row of the last cell >= then the row of the StartCell
                        If RDB_Last(1, .Cells) < .Range(StartCell).Row Then
                            Set SourceRange = Nothing
                        End If
                    End With
                Else
                    With mybook.Sheets(SourceSh)
                        Set SourceRange = Application.Intersect(.UsedRange, .Range(SourceRng))
                    End With
                End If
                If Err.Number > 0 Then
                    Err.Clear
                    Set SourceRange = Nothing
                Else
                    'if SourceRange use all columns then skip this file
                    If SourceRange.Columns.Count >= Sheet1.Columns.Count Then
                        Set SourceRange = Nothing
                    End If
                End If
                On Error GoTo 0
                If Not SourceRange Is Nothing Then
                    'Check if there enough rows to paste the data
                    SourceRcount = SourceRange.Rows.Count
                    If rnum + SourceRcount >= Sheet1.Rows.Count Then
                        MsgBox "Sorry there are not enough rows in the sheet to paste"
                        mybook.Close savechanges:=False
                        Sheet1.Parent.Close savechanges:=False
                        GoTo ExitTheSub
                    End If
                    'Set the destination cell
                    If FileNameInA = True Then
                        Set destrange = Sheet1.Range("C" & rnum)
                        With SourceRange
                            Sheet1.Cells(rnum, "B"). _
                                    Resize(.Rows.Count).Value = myReturnedFiles(I)
                        End With
                    Else
                        Set destrange = Sheet1.Range("B" & rnum)
                    End If
                    'Copy/paste the data
                    If PasteAsValues = True Then
                        With SourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = SourceRange.Value
                    Else
                        SourceRange.Copy destrange
                    End If
                    rnum = rnum + SourceRcount
                End If
                'Close the workbook without saving
                mybook.Close savechanges:=False
            Else
                'Loop through all sheets in mybook
                For Each sh In mybook.Worksheets
                    'Set SourceRange and check if it is a valid range
                    On Error Resume Next
                    If StartCell <> "" Then
                        With sh
                            Set SourceRange = .Range(StartCell & ":" & RDB_Last(3, .Cells))
                            If RDB_Last(1, .Cells) < .Range(StartCell).Row Then
                                Set SourceRange = Nothing
                            End If
                        End With
                    Else
                        With sh
                            Set SourceRange = Application.Intersect(.UsedRange, .Range(SourceRng))
                        End With
                    End If
                    If Err.Number > 0 Then
                        Err.Clear
                        Set SourceRange = Nothing
                    Else
                        'if SourceRange use almost all columns then skip this file
                        If SourceRange.Columns.Count > Sheet1.Columns.Count - 2 Then
                            Set SourceRange = Nothing
                        End If
                    End If
                    On Error GoTo 0
                    If Not SourceRange Is Nothing Then
                        'Check if there enough rows to paste the data
                        SourceRcount = SourceRange.Rows.Count
                        If rnum + SourceRcount >= ActiveWorkbook.Rows.Count Then
                            MsgBox "Sorry there are not enough rows in the sheet to paste"
                            mybook.Close savechanges:=False
                            ActiveWorkbook.Parent.Close savechanges:=False
                            GoTo ExitTheSub
                        End If
                        'Set the destination cell
                        If FileNameInA = True Then
                            Set destrange = Sheet1.Range("C" & rnum)
                            With SourceRange
                                Sheet1.Cells(rnum, "A"). _
                                        Resize(.Rows.Count).Value = myReturnedFiles(I)
                                Sheet1.Cells(rnum, "B"). _
                                        Resize(.Rows.Count).Value = sh.Name
                            End With
                        Else
                            Set destrange = Sheet1.Range("A" & rnum)
                        End If
                        'Copy/paste the data
                        If PasteAsValues = True Then
                            With SourceRange
                                Set destrange = destrange. _
                                                Resize(.Rows.Count, .Columns.Count)
                            End With
                            destrange.Value = SourceRange.Value
                        Else
                            SourceRange.Copy destrange
                        End If
                        rnum = rnum + SourceRcount
                    End If
                Next sh
                'Close the workbook without saving
                mybook.Close savechanges:=False
            End If
        End If
        'Open the next workbook
    Next I
   
ExitTheSub:
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub
 

Some videos you may like

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.

Watch MrExcel Video

Forum statistics

Threads
1,089,992
Messages
5,411,712
Members
403,391
Latest member
electropro

This Week's Hot Topics

Top