GetData keeping source format + Destionation Range

[gubertu]

Hi all,

I trust you can help me out with the following Getdata Code to copy data from closed WB to an open WB

In this code I can specify:

1. The path where the source files are (closed workbooks)
Sheet1.Cell "C4" = C:\Users\USD

2. The name and the range of the sheet of the source file I want to copy (closed workbooks).
Sheet1.Cell "D4" = A5
Sheet1.Cell "E4" = A1:BL80

3. The name of the sheet in the open workbook I want to paste the information.
Sheet1.Cell "F4" = A5

But additionally, it I would like to know if it is possible to do the following:

4. Tell the macro to paste the information in the open WB, starting in the cell I want (for example "B5").
5. Keep the source formating when I paste the information in the open WB.
6. Lets say I want to copy the range A1:BL80, sheet "A5" from the closed WB and paste with the source format in the open WB, sheet A5, starting in cell "B5". Therefore I will have the information from cells B5 to B85. Would it be possible to place in cell B4 the name of the source workbook? This WB is called "SUMMARY".


Thanks in advance for your help!

Sub Get_Data()
    Dim MyPath As String
    Dim FilesInPath As String
    Dim sh As Worksheet
    Dim MyFiles() As String
    Dim Fnum As Long
    Dim rnum As Long
    Dim destrange As Range
    Dim i As String
    Dim Rng As Range
   
    MyPath = Sheets("Sheet1").Range("C4")    ' <<<<  Change
    'Fill the array(myFiles) with the list of Excel files in the folder
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop
    'Loop through all files in the array(myFiles)
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
          
            Set sh = Sheets(Sheets("Sheet1").Range("F4").Value)
               
            'Find the last row with data
            rnum = LastCol(sh)

 
            'create the destination cell address        
            Set destrange = sh.Cells(1, rnum + 2)
          'Get the cell values and copy it in the destrange
          'Change the Sheet name and range as you like
          GetData MyPath & MyFiles(Fnum), Sheets("Sheet1").Range("D4"), _
            Sheets("Sheet1").Range("E4"), destrange, False, False
     
        Next
    End If
End Sub

Option Explicit
Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
                   SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
    Dim rsCon As Object
    Dim rsData As Object
    Dim szConnect As String
    Dim szSQL As String
    Dim lCount As Long


    ' Create the connection string.
    If Header = False Then
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=No"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=No"";"
        End If
    Else
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=Yes"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=Yes"";"
        End If
    End If


    If SourceSheet = "" Then
        ' workbook level name
        szSQL = "SELECT * FROM " & SourceRange$ & ";"
    Else
        ' worksheet level name or range
        szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
    End If


    On Error Resume Next


    Set rsCon = CreateObject("ADODB.Connection")
    Set rsData = CreateObject("ADODB.Recordset")


    rsCon.Open szConnect
    rsData.Open szSQL, rsCon, 0, 1, 1


    ' Check to make sure we received data and copy the data
    If Not rsData.EOF Then


        If Header = False Then
            TargetRange.Cells(1, 1).CopyFromRecordset rsData
        Else
            'Add the header cell in each column if the last argument is True
            If UseHeaderRow Then
                For lCount = 0 To rsData.Fields.Count - 1
                    TargetRange.Cells(1, 1 + lCount).Value = _
                    rsData.Fields(lCount).Name
                Next lCount
                TargetRange.Cells(2, 1).CopyFromRecordset rsData
            Else
                TargetRange.Cells(1, 1).CopyFromRecordset rsData
            End If
        End If


    Else
        
    End If


    ' Clean up our Recordset object.
    rsData.Close
    Set rsData = Nothing
    rsCon.Close
    Set rsCon = Nothing
    Exit Sub


    On Error GoTo 0


End Sub


Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function