在VBA中使用Loop将查询从Access-Form导出到Excel

I want to Export large data stock from Access to Excel. I'm doing that with a form.

我想从Access导出大数据库存到Excel。我是用表格做的。

My code with "DoCmd.TransferSpreadsheet acExport..." works normally, but the program breaks off because of the large data stock.

我的代码“DoCmd.TransferSpreadsheet acExport ...”正常工作，但由于数据量很大，程序中断。

Perhaps with queries I can solve this Problem, or what do you think?

也许有查询我可以解决这个问题，或者你怎么想？

I am thankful for each tip! =)

我很感谢每个小费！ =）

1 个解决方案

#1

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

您可以使用下面的代码：这将复制表单中的日期表视图并将其复制粘贴到一个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