Разбор данных из Access в Excel с помощью кода vba для разделения на листы в зависимости от содержимого поля

Question

Я пытался найти способ адаптировать код, который я написал (в значительной степени на основе видео Youtube и кодирования, предоставленного Access Jitsu, чтобы разделить мои данные на несколько листов на основе значения в одном поле. У меня есть номер полей, и цель состоит в том, чтобы сравнить выставление счетов и расходы, которые я хочу разделить по годам на отдельные листы в Excel. в поле Год (в коде [Yr]).

заранее большое спасибо.

Код ниже. Не удалось отобразить его как одну запись

Private Sub Command2_Click()
On Error GoTo SubError

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim SQL As String
Dim rs1 As DAO.Recordset
Dim i As Integer

'Show user work is being performed
DoCmd.Hourglass (True)

'*********************************************
'              RETRIEVE DATA
'*********************************************
'SQL statement to retrieve data from database
SQL = "SELECT [Job Opened], [Job Number], [Job Title], " & _
"[ProposalRef], [QuotedValue], [Invoiced], " & _
"[Uplifted Cost], [Profit], [Diff], [Last Date Worked], [Reason], [Status], [Yr]" & _
"FROM [BIID] " & _
"ORDER BY [Job Number] "


'Execute query and populate recordset
Set rs1 = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)

'If no data, don't bother opening Excel, just quit
If rs1.RecordCount = 0 Then
    MsgBox "No data selected for export", vbInformation + vbOKOnly, "No data exported"
    GoTo SubExit
End If

'*********************************************
'             BUILD SPREADSHEET
'*********************************************
'Create an instance of Excel and start building a spreadsheet

'Early Binding
Set xlApp = Excel.Application

xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)

With xlSheet
    .Name = "BIID-All"
    .Cells.Font.Name = "Calibri"
    .Cells.Font.Size = 10

    'Set column widths
    .Columns("A").ColumnWidth = 11
    .Columns("B").ColumnWidth = 10
    .Columns("C").ColumnWidth = 40
    .Columns("D").ColumnWidth = 16
    .Columns("E").ColumnWidth = 14
    .Columns("F").ColumnWidth = 12
    .Columns("G").ColumnWidth = 12
    .Columns("H").ColumnWidth = 12
    .Columns("I").ColumnWidth = 10
    .Columns("J").ColumnWidth = 15
    .Columns("K").ColumnWidth = 45
    .Columns("L").ColumnWidth = 8
    .Columns("M").ColumnWidth = 5

    'Format columns
    .Columns("A").NumberFormat = "dd/mm/yyyy"
    .Columns("J").NumberFormat = "dd/mm/yyyy"
    .Columns("F").NumberFormat = "£#,###,##0.00;-£#,###,##0.00"
    .Columns("G").NumberFormat = "£#,###,##0.00;-£#,###,##0.00"
    .Columns("H").NumberFormat = "£#,###,##0.00;-£#,###,##0.00"
    .Columns("I").NumberFormat = "#,###,##0.00%;-#,###,##0.00%"

    'Column Headings
    .Range("A2").Value = "Date Opened"
    .Range("B2").Value = "Job Number"
    .Range("C2").Value = "Job Title"
    .Range("D2").Value = "Proposal Ref."
    .Range("E2").Value = "Quoted Value"
    .Range("F2").Value = "Total Invoiced"
    .Range("G2").Value = "Uplifted Cost"
    .Range("H2").Value = "Proft"
    .Range("I2").Value = "Difference"
    .Range("J2").Value = "Last Date Worked"
    .Range("K2").Value = "Reason"
    .Range("L2").Value = "Status"
    .Range("M2").Value = "Year"

    .Range("A1").Value = "Date Updated"
    .Range("B1").Value = Date

    'Format Column Headings
    .Range("A2:M2").Cells.Font.Bold = True
    .Range("A2:M2").Cells.Font.Color = RGB(68, 84, 106)
    .Range("A2:B2").HorizontalAlignment = xlCenter
    .Range("E2:J2").HorizontalAlignment = xlCenter

    'provide initial value to row counter
    i = 3
    'Loop through recordset and copy date from recordset to sheet
    Do While Not rs1.EOF

        .Range("A" & i).Value = rs1![Job Opened]
        .Range("B" & i).Value = rs1![Job Number]
        .Range("C" & i).Value = rs1![Job Title]
        .Range("D" & i).Value = rs1![ProposalRef]
        .Range("E" & i).Value = rs1![QuotedValue]
        .Range("F" & i).Value = rs1![Invoiced]
        .Range("G" & i).Value = rs1![Uplifted Cost]
        .Range("H" & i).Value = rs1![Profit]
        .Range("I" & i).Value = rs1![Diff]
        .Range("J" & i).Value = rs1![Last Date Worked]
        .Range("K" & i).Value = rs1![Reason]
        .Range("L" & i).Value = rs1![Status]
        .Range("M" & i).Value = rs1![Yr]

        i = i + 1
        rs1.MoveNext

        Loop

        'Total Average %
        .Range("F" & i).HorizontalAlignment = xlRight
        .Range("F" & i, "H" & i).Merge
        .Range("F" & i).Value = "Average % Profit (Billed vs Uplifted Cost)"
        .Range("F" & i).Cells.Font.Bold = True
        .Range("I" & i).Formula = "=AVERAGE(I3:I" & i - 1

        'Add borders
        .Range("A2:M2").Borders(xlEdgeTop).LineStyle = XlLineStyle.xlContinuous
        .Range("A2:M2").Borders(xlEdgeBottom).LineStyle = XlLineStyle.xlContinuous
        .Range("A2:A" & i - 1).Borders(xlEdgeLeft).LineStyle = XlLineStyle.xlContinuous
        .Range("A2:M" & i - 1).Borders(xlEdgeRight).LineStyle = XlLineStyle.xlContinuous
        .Range("A2:M" & i - 1).Borders(xlInsideVertical).LineStyle = XlLineStyle.xlContinuous
        .Range("A2:M" & i - 1).Borders(xlEdgeBottom).LineStyle = XlLineStyle.xlContinuous

        'Add Conditional formatting
        With .Range("I3:I" & i).FormatConditions.Add(xlCellValue, xlGreater, 0)
            .Font.Color = RGB(0, 176, 80)
        End With
        With .Range("I3:I" & i).FormatConditions.Add(xlCellValue, xlLess, 0)
            .Font.Color = vbRed
        End With

    End With

SubExit:
On Error Resume Next
DoCmd.Hourglass False
xlApp.Visible = True
rs1.Close
Set rs1 = Nothing
Exit Sub

 SubError:
MsgBox "Error Number: " & Err.Number & "= " & Err.Description, vbCritical + vbOKOnly, _
    "An error occurred"
GoTo SubExit
 End Sub

Answer 1

Что вам нужно сделать, так это ввести новый набор записей, в котором есть список различных лет. Затем вы oop этот набор записей, добавляя новый рабочий лист для каждого года, а затем открывается ваш исходный набор записей, но в SQL есть пункт WHERE, чтобы просто показать данные за рассматриваемый год. Некоторые сокращенные VBA для этого приведены ниже:

Sub sSampleExport()
    On Error GoTo E_Handle
    Dim db As DAO.Database
    Dim rsYear As DAO.Recordset
    Dim rsData As DAO.Recordset
    Dim strSQL As String
    Dim objXL As New Excel.Application
    Dim objXLBook As Excel.Workbook
    Dim objXLSheet As Excel.Worksheet
    Dim lngLoop1 As Long
    Set db = DBEngine(0)(0)
    strSQL = "SELECT DISTINCT Yr FROM BIID ORDER BY Yr ASC;"
    Set rsYear = db.OpenRecordset(strSQL)
    If Not (rsYear.BOF And rsYear.EOF) Then
        Set objXLBook = objXL.Workbooks.Add
        Do
            Set objXLSheet = objXLBook.Worksheets.Add(After:=objXLBook.Worksheets(objXLBook.Worksheets.Count))
            With objXLSheet
                .name = rsYear!Yr
                strSQL = "SELECT [Job Opened], [Job Number], [Job Title] " _
                    & " FROM BIID " _
                    & " WHERE Yr=" & rsYear!Yr
                Set rsData = db.OpenRecordset(strSQL)
                If Not (rsData.BOF And rsData.EOF) Then
                    .Cells(1, 1).CopyFromRecordset rsData
                End If
            End With
            rsYear.MoveNext
        Loop Until rsYear.EOF
        For lngLoop1= objXLBook.Worksheets.Count To 1 Step -1
            If Left(objXLBook.Worksheets(lngLoop1).Name, 5) = "Sheet" Then
                objXLBook.Worksheets(lngLoop1).Delete
            End If
        Next lngLoop1
        objXLBook.Worksheets(1).Select
        objXLBook.SaveAs "J:\downloads\test.xlsx"
    End If
sExit:
    On Error Resume Next
    rsData.Close
    rsYear.Close
    Set rsData = Nothing
    Set rsYear = Nothing
    Set db = Nothing
    Set objXLSheet = Nothing
    objXLBook.Close
    Set objXLBook = Nothing
    objXL.Quit
    Set objXL = Nothing
    Exit Sub
E_Handle:
    MsgBox Err.Description & vbCrLf & vbCrLf & "sSampleExport", vbOKOnly + vbCritical, "Error: " & Err.Number
    Resume sExit
End Sub

С уважением,

Answer 2

Совет:

Do While Not rs1.EOF

    .Range("A" & i).Value = rs1![Job Opened]
    .Range("B" & i).Value = rs1![Job Number]
    .Range("C" & i).Value = rs1![Job Title]
    .Range("D" & i).Value = rs1![ProposalRef]
    .Range("E" & i).Value = rs1![QuotedValue]
    .Range("F" & i).Value = rs1![Invoiced]
    .Range("G" & i).Value = rs1![Uplifted Cost]
    .Range("H" & i).Value = rs1![Profit]
    .Range("I" & i).Value = rs1![Diff]
    .Range("J" & i).Value = rs1![Last Date Worked]
    .Range("K" & i).Value = rs1![Reason]
    .Range("L" & i).Value = rs1![Status]
    .Range("M" & i).Value = rs1![Yr]

    i = i + 1
    rs1.MoveNext

Loop

можно сократить до:

.Range("A" & i).CopyFromRecordset rs1