VBAのループを使用してAccess-FormからExcelにクエリをエクスポートする

Question

AccessからExcelに大量のデータをエクスポートしたい。私はフォームでそれをやっています。

"DoCmd.TransferSpreadsheet acExport..."のマイコードは正常に動作しますが、大量のデータが保存されているため、プログラムが中断します。

おそらく質問で私はこの問題を解決することができますか、あなたはどう思いますか？

各ヒントには感謝しています。 =）

Answer 1

あなたは以下のコードを使用することができます：これはあなたのフォーム内の日付シートビューをコピーし、1つの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