🚀 go-pugleaf

Może jeszcze dokończę poprzedniego posta.
Dlaczego piszę na forum MS Access?

Chciałem przygotować plik Excela z odpowiednią tabelą przestawną
nie wychodząc z aplikacji Accessa.
Wszystko dla użytkownika klikającego tylko na przycisk.

Pozdrawiam
/
MF

Czy z poniższego można by coś skompilować?

"
Private Sub Command11_Click()
On Error GoTo errhandler
Dim strFile As String
Dim lastrow As Long
Dim newapp As Object
Dim wb As Object
Dim ws As Object
Dim myrange As Object
strFile = Environ("temp") & "\ErrorReport.xls"
If Dir(strFile) <> "" Then Kill strFile
DoEvents
DoCmd.OutputTo acOutputQuery, "qry_ENROLLMENTREPORT", acFormatXLS, strFile, False
Set newapp = CreateObject("excel.application")
Set wb = newapp.Workbooks.Open(strFile)
Set ws = wb.sheets(1)
lastrow = ws.Range("I" & ws.Rows.Count).End(-4162).row
For Each myrange In ws.Range("I2:I" & lastrow)
    myrange.Value = "=HYPERLINK(" & Chr(34) & myrange.Value & Chr(34) & "," & Chr(34) & "Open APP" & Chr(34) & ")"
Next myrange
ws.Columns.AutoFit
ws.Columns(6).ColumnWidth = 20
ws.Columns(7).ColumnWidth = 20
'now parse out bad fields
Dim ws2 As Object
Set ws2 = wb.sheets.Add
ws2.Name = "Chart"
ws2.Range("A1").Value = "Error Type"
ws2.Range("A1").Font.Bold = True
Dim myArray As Variant
Dim z As Long
For Each myrange In ws.Range("k2:k" & lastrow)
    If InStr(2, myrange.Value, "|") = 0 Then
        ws2.Range("A" & ws2.Rows.Count).End(-4162).offset(1, 0).Value = Replace(myrange.Value, "|", "")
    Else 'else it's an array
    
        myArray = Split(myrange.Value, "|")
        For z = 0 To UBound(myArray)
            ws2.Range("A" & ws2.Rows.Count).End(-4162).offset(1, 0).Value = _
            myArray(z)
        Next z
    End If
Next myrange
'now code for adding pivot chart
Dim lngLastRow As Long
Dim strRange As Object 'sourcetype, per excel VBA help files, can be range type, i had  alotta trouble w/this @ first
lngLastRow = ws2.Range("A" & ws2.Rows.Count).End(-4162).row '-4162 is like xlUp if using early binding
Set strRange = ws2.Range("A1:A" & lngLastRow) 'set object to excel range type
wb.PivotCaches.Create(SourceType:=1, SourceData:= _
    strRange, Version:=1).CreatePivotTable _
    TableDestination:="Chart!R2C4", TableName:="PivotTable1", DefaultVersion _
    :=1
    'xlPivotTableVersion10 constant is like number 1 in late binding.
    'xlDatabase constant is like number 1 in late binding
Dim myChart As Object
ws2.Shapes.AddChart
Set myChart = ws2.ChartObjects(1).Chart
myChart.SetSourceData Source:=ws2.Range("D2:J100")
wb.ShowPivotChartActiveFields = True
myChart.ChartType = 51 '51 is numerical equivalent of excel OM constant, xlColumnClustered, if using early binding
With ws2.PivotTables("PivotTable1").PivotFields("Error Type")
    .Orientation = 1 '1 is numerical equivalent of excel om constant, xlRowField
    .Position = 1
End With
ws2.PivotTables("PivotTable1").AddDataField ws2.PivotTables( _
    "PivotTable1").PivotFields("Error Type"), "Count of Error Type", -4112 'num. equiv. of excel om constant, xlCount
    myChart.Legend.Delete
myChart.SeriesCollection(1).ChartType = 51
myChart.SeriesCollection(1).ApplyDataLabels
wb.ShowPivotChartActiveFields = False
myChart.ChartTitle.Text = "ERRORS"
myChart.ClearToMatchStyle
myChart.ChartStyle = 27
myChart.ClearToMatchStyle
With ws2.PivotTables("PivotTable1").PivotFields("Error Type")
    .Orientation = 1
    .Position = 1
End With
wb.refreshall
newapp.Visible = True
Set newapp = Nothing
Set wb = Nothing
Set ws = Nothing
Set myrange = Nothing
Exit Sub
errhandler:
If Not newapp Is Nothing Then Set newapp = Nothing
If Not newapp Is Nothing Then
    newapp.displayalerts = False
    newapp.Quit
End If
'AnyProgressLabelFormName.Visible=False
MsgBox "The following error has occurred: " _
& vbNewLine & vbNewLine & "If reporting this error, please STOP and include a screenshot of this error" _
& vbNewLine & "as well as the entire screen/program" _
& vbNewLine & vbNewLine & "Error description:  " & Err.Description _
& vbNewLine & "Error number:  " & Err.Number, vbCritical, "  "
Exit Sub
End Sub
"