I would like to copy the entire worksheet from one Closed Excel file to the currently open excel file however I do not want to use a range as the amount of rows in the file will vary.
The code I am using to rereive data from within a range is
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 GoTo SomethingWrong
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
MsgBox "No records returned from : " & SourceFile, vbCritical
End If
' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub
SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
vbExclamation, "Error"
On Error GoTo 0
End Sub
Any help with importing the entire worksheet and all of its rows/column would be great.
Thanks.
Why not just do this?
Dim wbkSource As Workbook
Set wbkSource = Workbooks.Open("C:\BookFromWhichToCopy.xlsx")
wbkSource.Sheets("MySheet").Copy Before:=ThisWorkbook.Sheets(2)
wbkSource.Close
Note that you can call sheets by their name .Sheets("MySheet") or by their number in the workbook .Sheets(2), whichever suits you best.
Related
I know this has probably been asked before but I was wondering if it was possible to copy data from another 'closed' workbook to my current open workbook. If tried to look up some things and everywhere says it is not possible... I know it's a bit of an open ended question.
Ah, this takes me back a few years. I believe this was done by Ron years ago (explained on a different platform). But there are two ways to do it. One method I forgot and gets the cells one by one and the other is the ADO method posted below. First there are two example subs (one method to bring headers and the other to not) and then followed by the main ADO sub.
Option Explicit
Sub GetData_ExampleV1()
' It will copy the Header row also (the last two arguments are True)
' Change the last argument to False if you not want to copy the header row
GetData ThisWorkbook.Path & "\test.xlsx", "Sheet1", _
"A1:C5", Sheets("Sheet1").Range("A1"), True, True
End Sub
Sub GetData_ExampleC2()
' It will not copy the Header row (the last two arguments are True, False)
' Change the last argument to True if you also want to copy the header row
GetData ThisWorkbook.Path & "\test.xlsx", "Sheet1", _
"A1:C5", Sheets("Sheet1").Range("A1"), True, False
End Sub
This is the ADO (function) you call to do it.
Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
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 GoTo SomethingWrong
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
MsgBox "No records returned from : " & SourceFile, vbCritical
End If
' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub
SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
vbExclamation, "Error"
On Error GoTo 0
End Sub
I'm trying to copy values from one workbook into another. The code below used to work. However, after making required updates (I'm on my work laptop, so don't really have a choice) to my Office, the connection to ADO in my macro no longer works.
This is the error I get:
Run-time error '-2147217865 (800040e37)':
The Microsoft Access database engine could not find the object 'CustomSheetName1$'. Make sure the object exists and that you spell its name and the path name correctly. If 'CustomSheetName1$' is not a local object, check your network connection or contact the server administrator.
I'm using Excel for Microsoft 365 MSO (16.0.13530.20368) 64-bit
The code breaks in the last line:
Public Sub GetData(sourceFile As Variant, SourceSheet As String, _
SourceRange As String, TargetRange As Range, _
Header As Boolean, UseHeaderRow As Boolean, _
pickUpZip As String, _
dropOffZip As String, logSheet As Worksheet, _
monthString As String)
Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long
Dim lastLgRow As Integer
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
szSQL = "SELECT * FROM " & SourceRange$ & ";"
Else
szSQL = "SELECT * FROM [" & SourceSheet$ & "$]"
szSQL = szSQL & " WHERE [Pickup Zip] LIKE '" & pickUpZip & "%'" & _
" AND [Drop Off Zip] LIKE '" & dropOffZip & "%" & "';"
End If
Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")
rsCon.Open szConnect
rsData.Open szSQL, rsCon, 0, 1, 1
I saw some people having similar issues when in their queries they specified a range of cells. However, this is not the case here, as I want to query the entire 'CustomSheetName1' spreadsheet.
Any ideas?
I'm not well VBA coder but here:
If SourceSheet = "" Then
szSQL = "SELECT * FROM " & SourceRange$ & ";"
Else
szSQL = "SELECT * FROM [" & SourceSheet$ & "$]"
should'nt this look like:
If SourceSheet = "" Then
szSQL = "SELECT * FROM [" & SourceRange & "$];"
Else
szSQL = "SELECT * FROM [" & SourceSheet & "$];"
?
Btw. I'm not sure what you want to do with SourceRange in place of SourceSheet
I have 2 excel workbooks and I am pulling data (A1:A20)from one (WB1) to another using below macro. I have problem that only records with numbers are pulled while string records are not. It seems that the field type is considered as a number and only numbers are being pulled. what should I change in the code to solve it?
below link includes the source file:
https://drive.google.com/open?id=0B64seB8-qtdLYk80N3hvX2F6VGc
Private Source As Variant
Sub Copy_Paste()
'copy the data from the source
Source = ThisWorkbook.Path & "\WB1.xlsx"
GetData Source, "Sheet1", "A1:A20", Sheets("Database").Range("A1")
End Sub
Public Sub GetData(Source As Variant, SourceSheet As String, SourceRange As String, TargetRange As Range)
Dim rsCon As Object
Dim rsData As Object
Dim szSQL As String
Dim szConnect As String
'Create the connection string based on excel version
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Source & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & Source & ";" & _
"Extended Properties=""Excel 12.0;HDR=No"";"
End If
szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
On Error GoTo SomethingWrong
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
TargetRange.Cells(1, 1).CopyFromRecordset rsData
Else
MsgBox "No records returned from : " & Source, vbCritical
End If
' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub
SomethingWrong:
MsgBox "The file name, Sheet name is invalid of : " & Source, vbExclamation, "Error"
On Error GoTo 0
End Sub
See here: https://social.msdn.microsoft.com/Forums/sqlserver/en-US/ce095b10-84a4-4ae3-8944-70a2b53daa44/mixed-data-types-in-excel-column-to-oedb-destination?forum=sqlintegrationservices
You need to add IMEX=1 to your connection strings. Eg:
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Source & ";" & _
"Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
Otherwise, the driver guesses your data column is numeric (based on the first few rows) and ignores any non-numeric values.
I have this code to copy and transpose data. It only copy one column to one row. I want to copy data for every 3 row into multiple row. For example:
1 become 123
2 456
3
4
5
6
This is my code to copy and transpose data. How can I do it like example above? Thanks for the help
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.ACE.OLEDB.12.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.ACE.OLEDB.12.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 GoTo SomethingWrong
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
' Copy and Transpose data to destination
Dim vDB
vDB = rsData.getRows
If Header = False Then
TargetRange.Cells(1, 1).Resize(UBound(vDB, 1) + 1, UBound(vDB, 2) + 1) = vDB
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
MsgBox "No records returned from : " & SourceFile, vbCritical
End If
' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub
You can use this code to transpose every 3 numbers into one row. Not sure if this is what you mean.
Sheet:
1 123
2 456
3 789
4
5
6
7
8
9
Code:
Sub BlaBlaBla()
Number = vbNullString
Row = 1
Count = 0
For i = 1 To 9
Number = Number & CStr(Sheets(1).Range("A" & i))
Count = Count + 1
If Count = 3 Then
Count = 0
Sheets(1).Range("B" & Row) = Number
Number = vbNullString
Row = Row + 1
End If
Next i
End Sub
Im using recursive function for getting specific data from files in folders and subfolders on my disk. This data are saved as a new row in my excel file and create the table. It works fine. But if I create new file and put it into random subfolder, after starting the recursive function, I want to add that data as new row in my table that was created before. Instead of removing whole table and then repeatedly start recursive function and get data in the table.
Something like refresh button - if I click on it, it will check every folder and subfolder and if find some new file or files, add them on the last row in the table.
This is the code I´m using now:
Function Recurse(sPath As String) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim mySubFolder As Folder
Dim myFile As File
Dim erow
Dim Black
Dim cislokabla
Set myFolder = FSO.GetFolder(sPath)
For Each mySubFolder In myFolder.SubFolders
For Each myFile In mySubFolder.Files
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
GetData myFile, "Sheet1", _
"F1:F2", Sheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 1)), True, False
Black = Sheet1.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
GetData myFile, "Sheet1", _
"O4:O5", Sheets("Sheet1").Range(Cells(Black, 2), Cells(Black, 2)), True, False
cislokabla = Sheet1.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row
GetData myFile, "Sheet1", _
"AH1:AH2", Sheets("Sheet1").Range(Cells(Black, 3), Cells(Black, 3)), True, False
Next
Recurse = Recurse(mySubFolder.Path)
Next
End Function
Sub nacitavaniedat()
Call Recurse("\\Sk-wftkabel\public\Identifikačné listy káblov\káble\")
End Sub
you need sheet2 named "Sheet2" to store filenames :)
(changed 30.01.14)
Sub Recurse()
Dim FSO As New FileSystemObject
Dim myFolder As Scripting.Folder, mySubFolder As Scripting.Folder
Dim myFile As File
Dim sPath$: sPath = "\\Sk-wftkabel\public\Identifikacne listy kablov\kable\"
Dim R$
R = Join(Application.Transpose(Sheets("Sheet2").UsedRange), "|")
Set myFolder = FSO.GetFolder(sPath)
For Each mySubFolder In myFolder.SubFolders
For Each myFile In mySubFolder.Files
DoEvents
If Not (InStr(1, R, myFile.Path) > 0) Then
GetData myFile, "Sheet1", "F1:F2", Sheets("Sheet1").Range(Sheets(1).Cells(Sheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1), Sheets(1).Cells(Sheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)), True, False
GetData myFile, "Sheet1", "O4:O5", Sheets("Sheet1").Range(Sheets(1).Cells(Sheet1.Cells(Rows.Count, 2).End(xlUp).Row + 1, 2), Sheets(1).Cells(Sheet1.Cells(Rows.Count, 2).End(xlUp).Row + 1, 2)), True, False
GetData myFile, "Sheet1", "AH1:AH2", Sheets("Sheet1").Range(Sheets(1).Cells(Sheet1.Cells(Rows.Count, 3).End(xlUp).Row + 1, 3), Sheets(1).Cells(Sheet1.Cells(Rows.Count, 3).End(xlUp).Row + 1, 3)), True, False
Sheets("Sheet2").Cells(Sheets("Sheet2").UsedRange.Rows.Count + 1, 1).Value = myFile.Path
R = R & myFile.Path & "|"
End If
Next
Next
Set FSO = Nothing
Set myFolder = Nothing
Set mySubFolder = Nothing
Set myFile = Nothing
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 GoTo SomethingWrong
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
MsgBox "No records returned from : " & SourceFile, vbCritical
End If
' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub
SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
vbExclamation, "Error"
On Error GoTo 0
End Sub