Export queries from Access-Form to Excel with Loop in VBA

Question

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

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

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

I am thankful for each tip! =)

Answer 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

  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