Merging Data in named ranges from multiple workbooks in single sheet

[leggylongshanks]

Hi All,
I have found this forum to be a great place to find information in the past, but I now need some direct assistance. My goal is to have specific data pulled out of a wide range of excel based purchase orders (po number, date, cost code, subtotal, total, etc..) and merge them into a PO log. As there is the chance of having non-PO excel files in the folders I will be searching through or employees modifying PO's by adding rows, I believe that naming the cells I need and then referencing that name is the way to go. I have been able to use some very helpful code by Ron DeBruin in the past to do this, but have now switched to some different code to help me with searching through sub-folders.

My problem is: How can I modify this code to grab specifically named cells (po,costcode,date,subtotal), rather than a traditional range (A1:B16) and plug them into a sheet? I believe only a small change would be required, but the programming experience I do have isn't helping me so far.

Here is an example of the DeBruin code I have been playing with. I took out most of code I have tried to enter because it just wasn't working the way I want it to.

Sub RDB_Merge_Data()
    Dim myFiles As Variant
    Dim porange As String
    Dim myCountOfFiles As Long
    Dim Addr As Variant
    Addr = Array("po", "supplier")
    myCountOfFiles = Get_File_Names( _
                     MyPath:="C:\Users\excelnewb\PO's\", _
                     Subfolders:=True, _
                     ExtStr:="*.xl*", _
                     myReturnedFiles:=myFiles)


    If myCountOfFiles = 0 Then
        MsgBox "No files that match the ExtStr in this folder"
        Exit Sub
    End If


    Get_Data _
            FileNameInA:=True, _
            PasteAsValues:=True, _
            SourceShName:="", _
            SourceShIndex:=1, _
            SourceRng:="", _
            StartCell:="", _
            myReturnedFiles:=myFiles


End Sub


'With the macro below you can browse to the folder instead of enter in in the code


Sub RDB_Merge_Data_Browse()
    Dim myFiles As Variant
    Dim myCountOfFiles As Long
    Dim oApp As Object
    Dim oFolder As Variant


    Set oApp = CreateObject("Shell.Application")


    'Browse to the folder
    Set oFolder = oApp.BrowseForFolder(0, "Select folder", 512)
    If Not oFolder Is Nothing Then


        myCountOfFiles = Get_File_Names( _
                         MyPath:=oFolder.Self.Path, _
                         Subfolders:=False, _
                         ExtStr:="*.xl*", _
                         myReturnedFiles:=myFiles)


        If myCountOfFiles = 0 Then
            MsgBox "No files that match the ExtStr in this folder"
            Exit Sub
        End If


        Get_Data _
                FileNameInA:=True, _
                PasteAsValues:=True, _
                SourceShName:="", _
                SourceShIndex:=1, _
                SourceRng:="A1:G1", _
                StartCell:="", _
                myReturnedFiles:=myFiles


    End If


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 = "Combine Sheet"


    'Set start row for the Data
    rnum = 1


    '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 >= BaseWks.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 >= BaseWks.Rows.Count Then
                        MsgBox "Sorry there are not enough rows in the sheet to paste"
                        mybook.Close savechanges:=False
                        BaseWks.Parent.Close savechanges:=False
                        GoTo ExitTheSub
                    End If


                    'Set the destination cell
                    If FileNameInA = True Then
                        Set destrange = BaseWks.Range("B" & rnum)
                        With SourceRange
                            BaseWks.Cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = myReturnedFiles(I)
                        End With
                    Else
                        Set destrange = BaseWks.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


                '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 > BaseWks.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 >= BaseWks.Rows.Count Then
                            MsgBox "Sorry there are not enough rows in the sheet to paste"
                            mybook.Close savechanges:=False
                            BaseWks.Parent.Close savechanges:=False
                            GoTo ExitTheSub
                        End If


                        'Set the destination cell
                        If FileNameInA = True Then
                            Set destrange = BaseWks.Range("C" & rnum)
                            With SourceRange
                                BaseWks.Cells(rnum, "A"). _
                                        Resize(.Rows.Count).Value = myReturnedFiles(I)
                                BaseWks.Cells(rnum, "B"). _
                                        Resize(.Rows.Count).Value = sh.Name
                            End With
                        Else
                            Set destrange = BaseWks.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


    'Set the column width in the new workbook
    BaseWks.Columns.AutoFit


ExitTheSub:
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

I really appreciate any help, I have been working on this whenever I get time but I'm lacking some of the fundamentals needed to get it perfect.

 

[leggylongshanks]

The code works great as it is for your standard type of range (A1:B55), but I just need to find the right bits to change so I can enter specific values into the 'srcrange' section of the GetData function seen near the top of the code. Once That is figured out the rest will fall into place.

Thanks