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!
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!
Code:
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
Last edited: