0
我想将大量数据股票从Access导出到Excel。我正在用一个表单来做这件事。使用VBA中的Loop将访问表单中的查询导出到Excel
我的代码与"DoCmd.TransferSpreadsheet acExport..."
正常工作,但由于大量数据库存,程序中断。
也许随着查询我可以解决这个问题,或者你怎么看?
我很感谢每个提示! =)
我想将大量数据股票从Access导出到Excel。我正在用一个表单来做这件事。使用VBA中的Loop将访问表单中的查询导出到Excel
我的代码与"DoCmd.TransferSpreadsheet acExport..."
正常工作,但由于大量数据库存,程序中断。
也许随着查询我可以解决这个问题,或者你怎么看?
我很感谢每个提示! =)
你可以使用下面的代码:这将复制你的表格中的日期视图并复制粘贴到一个excel文件中。为此,你只需从工具箱中拖动一个子表格控件到你的表格并设置此子表单的源数据的属性作为查询名称并替换代码中的子表单名称
Private Sub Command48_Click()
On Error GoTo Command13_Click_Err
Me.subformName.SetFocus
'DoCmd.GoToControl "Policy Ref"
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
Dim xlapp As Excel.Application
Set xlapp = CreateObject("Excel.Application")
With xlapp
.Workbooks.Add
.ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= _
False
.Cells.Select
.Cells.EntireColumn.AutoFit
.Visible = True
.Range("a1").Select
End With
Command13_Click_Exit:
Exit Sub
Command13_Click_Err:
MsgBox Error$
Resume Command13_Click_Exit
End sub
'=======================
you can you use below code: this will copy the datesheet view in your form and copy paste it in to one excel file .For this you just drag one sub form control from tool box in to your form and set the property of this sub form's source data as your query name and replace the sub form name in the code
Private Sub Command48_Click()
On Error GoTo Command13_Click_Err
Me.subformName.SetFocus
'DoCmd.GoToControl "Policy Ref"
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
Dim xlapp As Excel.Application
Set xlapp = CreateObject("Excel.Application")
With xlapp
.Workbooks.Add
.ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= _
False
.Cells.Select
.Cells.EntireColumn.AutoFit
.Visible = True
.Range("a1").Select
End With
Command13_Click_Exit:
Exit Sub
Command13_Click_Err:
MsgBox Error$
Resume Command13_Click_Exit
End sub
'''PPT
Sub pptExoprort()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim slideNum As Integer
Dim chartName As String
Dim tableName As String
Dim PPTCount As Integer
Dim PPSlideCount As Long
Dim oPPTShape As PowerPoint.Shape
Dim ShpNm As String
Dim ShtNm As String
Dim NewSlide As String
Dim myChart As PowerPoint.Chart
Dim wb As Workbook
Dim rngOp As Range
Dim ro As Range
Dim p As Integer
Dim v, v1, v2, v3, Vtot, VcaGr
Dim ws As Worksheet
Dim ch
Dim w As Worksheet
Dim x, pArr
Dim rN As String
Dim rt As String
Dim ax
Dim yTbN As String
'Call InitializeGlobal
''start year offset
prodSel = shtSet.Range("rSelProd")
x = shtSet.Range("rngMap").Value
pArr = fretPrVal(x, prodSel)
TY = 11 'number of years in chart
ThisWorkbook.Activate
Set w = ActiveSheet
Set PPApp = GetObject("", "Powerpoint.Application") '******************
PPTCount = PPApp.Presentations.Count
If PPTCount = 0 Then
MsgBox ("Please open a PPT to export the Charts!")
Exit Sub
End If
Set PPPres = PPApp.ActivePresentation '******************
For j = 0 To UBound(pArr)
If j = 0 Then
rN = "janport"
slideNum = 3
yTbN = "runport"
Else
rN = "janprod" & j
slideNum = 3 + j
yTbN = "runprod" & j
End If
chartName = "chtSalesPort"
Set PPSlide = PPPres.Slides(slideNum) '**************
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
Set myChart = PPSlide.Shapes(chartName).Chart '******************
myChart.ChartData.Activate '********************
Set wb = myChart.ChartData.Workbook '***********
Set ws = wb.Worksheets(1) '**************
Set rngOp = w.Range(rN).Offset(0, 1).Resize(12, 6)
Set ro = rngOp
' v1 = ro.Offset(1, 22).Resize(Lc, 1)
'ws.ListObjects("Table1").Resize Range("$A$1:$B$" & Ty + 1)
'ws.ListObjects("Table1").Resize Range("$A$1:$" & Chr(Lc + 1 + 64) & "$" & Ty + 1)
ws.Range("B2:g13").ClearContents '***********
rngOp.Copy '**********
ws.Range("B2:g13").PasteSpecial xlPasteValues '******************
End Sub
Sub Picture62_Click()
Dim charNamel As String
Dim leftm As Integer
Dim toptm As Integer
charNamel = "Chart 1"
leftm = 35
toptm = 180
Call chartposition(leftm, toptm, charNamel)
End Sub
Sub chartposition(leftm, toptm, charNamel)
ActiveSheet.ChartObjects(charNamel).Activate
'First we declare the variables we will be using
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
Dim activslidenumber As Integer
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
' If newPowerPoint.Presentations.Count = 0 Then
' newPowerPoint.Presentations.Add
' End If
'Show the PowerPoint
newPowerPoint.Visible = True
On Error GoTo endd:
activslidenumber = Str(GetActiveSlide(newPowerPoint.ActiveWindow).SlideIndex)
Set activeSlide = newPowerPoint.ActivePresentation.Slides(activslidenumber)
ActiveChart.ChartArea.Copy
On Error GoTo endddd:
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteDefault).Select
'activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
'activeSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, DisplayAsIcon:=msoFalse).Select
endddd:
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = leftm
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = toptm
GoTo enddddd:
endd:
MsgBox ("Please keep your PPT file opened")
enddddd:
End Sub
https://support.office.com/zh-cn/article/Excel-specifications-and-limits -1672b34d-7043-467e-8e27-269d656771c3,不超过1,048,576行 – Serg