从访问形式出口查询到VBA中的循环

Question

我想从访问Excel中导出大型数据库存。我正在使用表格。

我的"DoCmd.TransferSpreadsheet acExport..."代码正常工作，但是由于大数据库存而破裂。

也许有了查询，我可以解决这个问题，还是您怎么看？

我感谢每个提示！=）

Answer 1

您可以使用下面的代码：这将以您的表单复制日期表视图，然后将其复制到一个Excel文件中。对于此，您只需将一个子表单从工具框中拖动一个sub表单到您的表单并将此子表单源数据的属性设置为您的查询名称，并在代码中替换sub表单

中的sub表单名称

  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