A
Andrew @ CrazyCritters
Hi,
Finally after a lot of searching I've been able to find this code. I pasted
it into Access and got it to work (exporting from Access to a new Excel
workbook) however my real requirement is to have an Excel macro initiate the
importing of the data.
The reason for this is the end users using the data have no Access knowledge
(I have some).
You can assume:
The name of the workbook is Excel_Test.xls,
The Access database is Source_Data.mdb, and
The Access table name is tbl_Comm_Data.
Sub foobar()
Dim rs As ADODB.Recordset
Dim exApp As Excel.Application, exWB As Excel.Workbook
Dim i As Long, j As Long, tmpQuo As Currency, startPos As Long, recCount As
Long
Dim fldArr() As String, varArr() As Variant, tmpArr() As Variant
Dim tmpBool As Boolean
Const maxRows As Long = 65000
Set rs = New ADODB.Recordset
rs.Open "Select * From tbl_Comm_Data WHERE DEPT_NO = '902'",
CodeProject.Connection, _
adOpenStatic, adLockReadOnly
With rs
If Not .EOF Then
Set exApp = New Excel.Application
Set exWB = exApp.Workbooks.Add(1)
Else: .Close: Set rs = Nothing
Exit Sub
End If
ReDim fldArr(0 To .Fields.Count - 1)
For i = LBound(fldArr) To UBound(fldArr)
Let fldArr(i) = .Fields(i).Name
Next
Let recCount = .RecordCount
If recCount <= maxRows Then
With exWB.Worksheets(1)
Let .Range("a1").Resize(, UBound(fldArr) + 1).Value = fldArr
..Range("a2").CopyFromRecordset rs
End With
Else: Let tmpBool = True
Let varArr = rs.GetRows
End If
..Close: Set rs = Nothing
End With
If tmpBool Then
Let tmpQuo = recCount / maxRows
If Int(tmpQuo) = tmpQuo Then
Let j = tmpQuo
Else: Let j = Int(tmpQuo) + 1
End If
With exWB.Worksheets
For i = 1 To j
If i > 1 Then .Add after:=.Item(i - 1)
Let startPos = (i - 1) * maxRows + 1
Let tmpArr = TransposeDim(varArr, startPos, maxRows - 1)
With .Item(i)
Let .Range("a1").Resize(, UBound(fldArr) + 1).Value = fldArr
Let .Range("a2").Resize(UBound(tmpArr, 1) + 1, _
UBound(tmpArr, 2) + 1).Value = tmpArr
End With
Next
exApp.Goto .Item(1).Range("a1")
End With
End If
'close and save
exApp.DisplayAlerts = False
exWB.Close True, "T:\foobar.xls"
Set exWB = Nothing
exApp.DisplayAlerts = True
exApp.Quit: Set exApp = Nothing
MsgBox "Ta da"
End Sub
Function TransposeDim( _
ByRef v() As Variant, _
Optional ByRef custStart As Long = 1, _
Optional ByRef custEnd As Long = 65535) As Variant
' Custom Function to Transpose a 0-based array (v) (MSDN)
' Crop-Functionality and Row-Cap Mods by Nate Oliver
Dim X As Long, Y As Long, custUbound As Long
Dim tmpArr() As Variant
Let custUbound = UBound(v, 2) - custStart + 1
If custUbound > custEnd Then Let custUbound = custEnd
ReDim tmpArr(0 To custUbound, 0 To UBound(v, 1))
For X = LBound(tmpArr, 1) To UBound(tmpArr, 1)
For Y = LBound(tmpArr, 2) To UBound(tmpArr, 2)
Let tmpArr(X, Y) = v(Y, X + custStart - 1)
Next Y
Next X
Let TransposeDim = tmpArr
End Function
Andrew
251108
Finally after a lot of searching I've been able to find this code. I pasted
it into Access and got it to work (exporting from Access to a new Excel
workbook) however my real requirement is to have an Excel macro initiate the
importing of the data.
The reason for this is the end users using the data have no Access knowledge
(I have some).
You can assume:
The name of the workbook is Excel_Test.xls,
The Access database is Source_Data.mdb, and
The Access table name is tbl_Comm_Data.
Sub foobar()
Dim rs As ADODB.Recordset
Dim exApp As Excel.Application, exWB As Excel.Workbook
Dim i As Long, j As Long, tmpQuo As Currency, startPos As Long, recCount As
Long
Dim fldArr() As String, varArr() As Variant, tmpArr() As Variant
Dim tmpBool As Boolean
Const maxRows As Long = 65000
Set rs = New ADODB.Recordset
rs.Open "Select * From tbl_Comm_Data WHERE DEPT_NO = '902'",
CodeProject.Connection, _
adOpenStatic, adLockReadOnly
With rs
If Not .EOF Then
Set exApp = New Excel.Application
Set exWB = exApp.Workbooks.Add(1)
Else: .Close: Set rs = Nothing
Exit Sub
End If
ReDim fldArr(0 To .Fields.Count - 1)
For i = LBound(fldArr) To UBound(fldArr)
Let fldArr(i) = .Fields(i).Name
Next
Let recCount = .RecordCount
If recCount <= maxRows Then
With exWB.Worksheets(1)
Let .Range("a1").Resize(, UBound(fldArr) + 1).Value = fldArr
..Range("a2").CopyFromRecordset rs
End With
Else: Let tmpBool = True
Let varArr = rs.GetRows
End If
..Close: Set rs = Nothing
End With
If tmpBool Then
Let tmpQuo = recCount / maxRows
If Int(tmpQuo) = tmpQuo Then
Let j = tmpQuo
Else: Let j = Int(tmpQuo) + 1
End If
With exWB.Worksheets
For i = 1 To j
If i > 1 Then .Add after:=.Item(i - 1)
Let startPos = (i - 1) * maxRows + 1
Let tmpArr = TransposeDim(varArr, startPos, maxRows - 1)
With .Item(i)
Let .Range("a1").Resize(, UBound(fldArr) + 1).Value = fldArr
Let .Range("a2").Resize(UBound(tmpArr, 1) + 1, _
UBound(tmpArr, 2) + 1).Value = tmpArr
End With
Next
exApp.Goto .Item(1).Range("a1")
End With
End If
'close and save
exApp.DisplayAlerts = False
exWB.Close True, "T:\foobar.xls"
Set exWB = Nothing
exApp.DisplayAlerts = True
exApp.Quit: Set exApp = Nothing
MsgBox "Ta da"
End Sub
Function TransposeDim( _
ByRef v() As Variant, _
Optional ByRef custStart As Long = 1, _
Optional ByRef custEnd As Long = 65535) As Variant
' Custom Function to Transpose a 0-based array (v) (MSDN)
' Crop-Functionality and Row-Cap Mods by Nate Oliver
Dim X As Long, Y As Long, custUbound As Long
Dim tmpArr() As Variant
Let custUbound = UBound(v, 2) - custStart + 1
If custUbound > custEnd Then Let custUbound = custEnd
ReDim tmpArr(0 To custUbound, 0 To UBound(v, 1))
For X = LBound(tmpArr, 1) To UBound(tmpArr, 1)
For Y = LBound(tmpArr, 2) To UBound(tmpArr, 2)
Let tmpArr(X, Y) = v(Y, X + custStart - 1)
Next Y
Next X
Let TransposeDim = tmpArr
End Function
Andrew
251108