QuickDraw
09-29-2005, 08:19 AM
I would like to copy Sheet1 from a closed workbook to a new workbook. Based on my searches I've been able to use ADO to get some properties of the closed workbook (row and column counts) as well as create a new workbook. I'm at a loss as to how to use ADO to copy from a closed workbook to a new workbook. I would like to copy the contents of Sheet1 (Row 1 is a header). Any help would be appreciated.
Private Sub CommandButton1_Click()
' Get file to convert using directory dialog
BrowseForFile "c:\", "Excel File (*.xls);*.xls", "Select Workbook"
'No file selected
If booCancel = True Then
Exit Sub
End If
MsgBox FULL_FILENAME
' Get no. of columns
Dim lngCols As Long
lngCols = ColumnCount( _
FULL_FILENAME, "Sheet1$")
MsgBox "No. of columns: " & CStr(lngCols)
' Get no. of rows
Dim lngRows As Long
'retrieves one row less than actual (doesn't include headers) so add 1
lngRows = RowCount( _
FULL_FILENAME, "Sheet1$") + 1
MsgBox "No. of rows: " & CStr(lngRows)
'Create new workbook and copy sheet 1
Set wb = NewWorkbook(1)
End Sub
Public Function ColumnCount(ByVal FullFilename As String, _
ByVal TableName As String) As Long
Dim Con As Object
Dim rs As Object
Dim strCon As String
Const CONN_STRING As String = "" & "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=<FULL_FILENAME>;" & _
"Extended Properties='Excel 8.0;HDR=YES'"
' Build connection string
strCon = CONN_STRING
strCon = Replace(strCon, "<FULL_FILENAME>", FullFilename)
' Open connection to workbook
Set Con = CreateObject("ADODB.Connection")
With Con
.CursorLocation = 3 ' client-side
.ConnectionString = strCon
.Open
' Get column schema details
Set rs = .OpenSchema(4, _
Array(Empty, Empty, TableName, Empty))
End With
With rs
.ActiveConnection = Nothing
Con.Close
ColumnCount = .RecordCount
End With
End Function
Public Function RowCount(ByVal FullFilename As String, _
ByVal TableName As String) As Variant
Dim Con As Object
Dim rs As Object
Dim strCon As String
Dim strSql1 As String
Const CONN_STRING As String = "" & "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=<FULL_FILENAME>;" & _
"Extended Properties='Excel 8.0;HDR=YES'"
Const SQL As String = "" & "SELECT COUNT(*) FROM [<TABLE_NAME>];"
' Build connection string
strCon = CONN_STRING
strCon = Replace(strCon, "<FULL_FILENAME>", FullFilename)
' Build sql
strSql1 = SQL
strSql1 = Replace(strSql1, "<TABLE_NAME>", TableName)
' Open connection to workbook
Set Con = CreateObject("ADODB.Connection")
With Con
.CursorLocation = 3 ' client-side
.ConnectionString = strCon
.Open
Set rs = .Execute(strSql1)
End With
With rs
.ActiveConnection = Nothing
Con.Close
.MoveLast
RowCount = .Fields(0).Value
End With
End Function
Function NewWorkbook(wsCount As Integer) As Workbook
' creates a new workbook with wsCount (1 to 255) worksheets
Dim OriginalWorksheetCount As Long
Set NewWorkbook = Nothing
If wsCount < 1 Or wsCount > 255 Then Exit Function
OriginalWorksheetCount = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = wsCount
Set NewWorkbook = Workbooks.Add
ActiveWorkbook.SaveAs InputBox("File Name")
Application.SheetsInNewWorkbook = OriginalWorksheetCount
'Sheets("Sheet1").Select
'Sheets("Sheet1").Name = "Summary"
End Function
Public Sub PutRecordSetInSheet(ByVal FullFilename As String, _
ByVal TableName As String)
'????????????????????????????
End Sub
Private Sub CommandButton1_Click()
' Get file to convert using directory dialog
BrowseForFile "c:\", "Excel File (*.xls);*.xls", "Select Workbook"
'No file selected
If booCancel = True Then
Exit Sub
End If
MsgBox FULL_FILENAME
' Get no. of columns
Dim lngCols As Long
lngCols = ColumnCount( _
FULL_FILENAME, "Sheet1$")
MsgBox "No. of columns: " & CStr(lngCols)
' Get no. of rows
Dim lngRows As Long
'retrieves one row less than actual (doesn't include headers) so add 1
lngRows = RowCount( _
FULL_FILENAME, "Sheet1$") + 1
MsgBox "No. of rows: " & CStr(lngRows)
'Create new workbook and copy sheet 1
Set wb = NewWorkbook(1)
End Sub
Public Function ColumnCount(ByVal FullFilename As String, _
ByVal TableName As String) As Long
Dim Con As Object
Dim rs As Object
Dim strCon As String
Const CONN_STRING As String = "" & "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=<FULL_FILENAME>;" & _
"Extended Properties='Excel 8.0;HDR=YES'"
' Build connection string
strCon = CONN_STRING
strCon = Replace(strCon, "<FULL_FILENAME>", FullFilename)
' Open connection to workbook
Set Con = CreateObject("ADODB.Connection")
With Con
.CursorLocation = 3 ' client-side
.ConnectionString = strCon
.Open
' Get column schema details
Set rs = .OpenSchema(4, _
Array(Empty, Empty, TableName, Empty))
End With
With rs
.ActiveConnection = Nothing
Con.Close
ColumnCount = .RecordCount
End With
End Function
Public Function RowCount(ByVal FullFilename As String, _
ByVal TableName As String) As Variant
Dim Con As Object
Dim rs As Object
Dim strCon As String
Dim strSql1 As String
Const CONN_STRING As String = "" & "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=<FULL_FILENAME>;" & _
"Extended Properties='Excel 8.0;HDR=YES'"
Const SQL As String = "" & "SELECT COUNT(*) FROM [<TABLE_NAME>];"
' Build connection string
strCon = CONN_STRING
strCon = Replace(strCon, "<FULL_FILENAME>", FullFilename)
' Build sql
strSql1 = SQL
strSql1 = Replace(strSql1, "<TABLE_NAME>", TableName)
' Open connection to workbook
Set Con = CreateObject("ADODB.Connection")
With Con
.CursorLocation = 3 ' client-side
.ConnectionString = strCon
.Open
Set rs = .Execute(strSql1)
End With
With rs
.ActiveConnection = Nothing
Con.Close
.MoveLast
RowCount = .Fields(0).Value
End With
End Function
Function NewWorkbook(wsCount As Integer) As Workbook
' creates a new workbook with wsCount (1 to 255) worksheets
Dim OriginalWorksheetCount As Long
Set NewWorkbook = Nothing
If wsCount < 1 Or wsCount > 255 Then Exit Function
OriginalWorksheetCount = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = wsCount
Set NewWorkbook = Workbooks.Add
ActiveWorkbook.SaveAs InputBox("File Name")
Application.SheetsInNewWorkbook = OriginalWorksheetCount
'Sheets("Sheet1").Select
'Sheets("Sheet1").Name = "Summary"
End Function
Public Sub PutRecordSetInSheet(ByVal FullFilename As String, _
ByVal TableName As String)
'????????????????????????????
End Sub