將 Access 表數據復制到 Excel 表

Question

我正在嘗試將表從 Access 數據庫復制到名為“ALL”的 Excel 工作表。 工作表保持空白。

數據被附加在一個名為“count”的表中，其中有一個 pivot 表。

我花了三天時間探索這個，但沒有找到解決方案。

     ' This function is used to calculate the number of rows
     Function lastrow() As Long
     Dim ix As Long
     ix = ActiveSheet.UsedRange.row - 1 + ActiveSheet.UsedRange.Rows.count
     lastrow = ix
     End Function
     
     Sub Macro1()
     '
     ' Macro1 Macro
      ' change the path where you want to save the workbooks
     
     Dim Path As String
     Path = ThisWorkbook.Path & "\"
     
     Dim main_w As String
     Dim data_file As String
     Dim new_wb As String
     Dim created As Integer
     Dim dept As Range
     Dim adviser As Range
     Dim MJRL_COLN_NUM As Integer
     Dim Counter As Integer
     Dim rw As Range
     Dim curCell As Range
     Dim Cell As Range
     Dim nextCell As Range
     
     'Path = "U:\Macros\Adviser Macro\"
     
     main_w = ThisWorkbook.Name
     
     data_file = Workbooks.Open(Path + "data_file.xls").Name
     
     created = 1
     
     For Each dept In Columns(1).Cells
         If (dept.Text = "") Then GoTo 1
     '    MsgBox (dept.Text)
     
         If (created = 1) Then new_wb = Workbooks.Add.Name
             
         Windows(main_w).Activate    'activate the workbook
         
         Sheets("Sheet1").Select
         
         Cells.Select
         Selection.AutoFilter
         Selection.AutoFilter Field:=60, Criteria1:=dept.Text
         
         Range("A1").Select
         Range(Selection, Selection.End(xlToRight)).Select
         Range(Selection, Selection.End(xlDown)).Select
         Selection.Copy
         
         created = 0
             
         If (ActiveWindow.RangeSelection.Rows.count < 4000) Then
         
             Windows(new_wb).Activate
             ActiveSheet.Name = "ALL"
             ActiveSheet.Paste
         
         Cells.Select
         Selection.RowHeight = 12.75
         Cells.EntireColumn.AutoFit
         
         'sort records by dept, then by adv_name, then by id
         ActiveSheet.Range("A2").Sort Key1:=ActiveSheet.Range("BH1"), _
                                      Key2:=ActiveSheet.Range("BI1"), _
                                      Key3:=ActiveSheet.Range("C1"), _
                                      Header:=xlYes
         
                     
             '''''''''''''''''''''''''''''''''''''''''''
             Windows(data_file).Activate
             
             
             For Each adviser In Columns(2).Cells
                 If (adviser.Text = "") Then GoTo 2
                 'MsgBox adviser.Text
                 
                 Windows(new_wb).Activate
                 
                 Cells.Select
                 Selection.AutoFilter
                 Selection.AutoFilter Field:=61, Criteria1:=adviser.Text
       
                 
                 Range("A1").Select
                 Range(Selection, Selection.End(xlToRight)).Select
                 Range(Selection, Selection.End(xlDown)).Select
                 Selection.Copy
                    
                 If (ActiveWindow.RangeSelection.Rows.count < 1500) Then
                 
                     Sheets.Add
                     ActiveSheet.Name = adviser.Text
                     ActiveSheet.Paste
                     'Sort the records according to major, class, then ID
                     ActiveSheet.Range("A2").Sort Key1:=ActiveSheet.Range("BH1"), _
                                                  Key2:=ActiveSheet.Range("BI1"), _
                                                  Key3:=ActiveSheet.Range("C1"), _
                                                  Header:=xlYes
                                                  
                     'place the neccessary borders (seperators)
                     '31 is the number of the Major_code column
                     MJRL_COLN_NUM = 31
                     Counter = 2
                     For Each rw In ActiveSheet.Rows
                          Set curCell = ActiveSheet.Cells(Counter, MJRL_COLN_NUM)
                          
                          If (curCell.Value = "") Then GoTo 3
                           
                          Set nextCell = ActiveSheet.Cells(Counter + 1, MJRL_COLN_NUM)
                          If curCell.Value <> nextCell.Value Then
                             'add a line border*************************
                             Set Cell = ActiveSheet.Cells(Counter, 1)
                             Range(Cell, Cell.End(xlToRight)).Borders(xlEdgeBottom).Weight = xlMedium
                          End If
                          Counter = Counter + 1
                     Next
             
     3:      Cells.Select
             Selection.RowHeight = 12.75
             Cells.EntireColumn.AutoFit
             Range("A1").Select
             ActiveWorkbook.Sheets("ALL").Activate
     
                 End If
             Next
     2:
             ActiveWorkbook.Sheets("ALL").Activate
             Cells.Select
             Selection.AutoFilter
             Range("A1").Select
     
     
             ' This sub will add the sheet Count to each workbook it will simply copy paste from
             ' the pivot table of the adviser distribution
             
             Dim rngend As Long
             Dim n As Long
             Dim row As Integer
             Dim row_total As Integer
             Dim str As String
             n = 3
             
             ' Activating the count sheet
             
             Windows("adviser counts (1 & 2).xls").Activate
             Sheets("Sheet3").Select
             
             ' Selecting the Department Column
             ActiveSheet.Cells(3, 1).Select
             
             
             rngend = lastrow() - 1
      
             Do While n < rngend
                 
                 If ActiveCell.Value = dept.Text Then
                     row = n
                 End If
                    
                 
                 If ActiveCell.Value = dept.Text & " Total" Then
                     row_total = n
                     'If ActiveCell.Value = "UPP Total" Then
                     '    MsgBox row_total
                     'End If
                 End If
                 
             'MsgBox row_total
             n = n + 1
             ActiveCell.Offset(1, 0).Select
             Loop
             
             ActiveSheet.Rows("1:2").Select
             Selection.Copy
             
             ' need to change to appropriate files
             
             Windows(new_wb).Activate
              Dim A2 As Integer
             A2 = 20
             For A2 = 0 To A2 Step 1
             If SheetExists("Sheet:" & A2) Then
             Sheets("Sheet:" & A2).Select
             Exit For
             End If
             Next
             
             ActiveSheet.Cells(1, 1).Select
             ActiveSheet.Paste
             
             Windows("adviser counts (1 & 2).xls").Activate
             Sheets("Sheet3").Select
             
            
             ActiveSheet.Rows(row & ":" & row_total).Select
             Selection.Copy
             
             Windows(new_wb).Activate
             
             Dim A1 As Integer
             A1 = 20
             For A1 = 0 To A1 Step 1
             If SheetExists("Sheet:" & A2) Then
             Sheets("Sheet:" & A2).Select
             Exit For
             End If
             Next
             
             ActiveSheet.Name = "count"
             ActiveSheet.Cells(3, 1).Select
             ActiveSheet.Paste
             Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
             SkipBlanks:=False, Transpose:=False
             
             Sheets("count").Select
             Sheets("count").Move Before:=Sheets(2)
             
             
             Sheets("ALL").Select
             Sheets("ALL").Move Before:=Sheets(1)
              
             
             ActiveWorkbook.SaveAs (Path & dept.Text)
             ActiveWorkbook.Close
             
                 
             created = 1
         End If
         
         Windows(main_w).Activate
         
         
     Next
     1:
     
     Windows(data_file).Close
     
     '
     End Sub
     
     
     Function SheetExists(sheetName As String) As Boolean
     Dim wk As Worksheet
     On Error Resume Next
     Set wk = ActiveWorkbook.Sheets(sheetName)
     SheetExists = Not (wk Is Nothing)
     Set wk = Nothing
     On Error GoTo 0
     End Function
     

我希望所有工作表的 output 出現在工作表“ALL”中，並且計算工作表僅包含其 pivot 表。

Answer 1

這一行在這里：

ActiveSheet.Name = "ALL"

正在將當前活動工作表重命名為“ALL”。 您應該考慮將該行更改為 select 表格，而不是像這樣：

Worksheets("ALL").Activate

或者

Sheets("ALL").Select

Answer 2

本節：

         ' need to change to appropriate files

         Windows(new_wb).Activate
          Dim A2 As Integer
         A2 = 20
         For A2 = 0 To A2 Step 1
         If SheetExists("Sheet:" & A2) Then
         Sheets("Sheet:" & A2).Select
         Exit For
         End If
         Next

沒有意義（至少對我來說）。

• 您正在尋找一些名稱在"Sheet:0"和"Sheet:20"之間的工作表。 但是（假設我已經理解了前面的代碼）當時的工作簿（名為new_wb ）將只包含 2 張； 即ALL和任何Adviser.Text評估的內容。
• 如果For循環內的條件始終為False ，您的代碼將不會激活您要粘貼到的工作表——這意味着您可能會繼續粘貼到For循環之前處於活動狀態的任何工作表。
• 最好將此部分放入返回工作表的 function 中。 這樣一來，它要么返回Worksheet要么返回Nothing並且消除了它靜默失敗的可能性。
• 您聲明變量A1和A2 ，但在兩個For循環中您只使用A2 。 也許這是故意的，或者您復制粘貼並忘記更新。

---

• created似乎是一個標志，指示是否在當前循環迭代期間創建新工作簿。 它似乎只是整個代碼中的兩個值之一（ 1或0 ），因此最好將其聲明為類型Boolean 。
• 但是，如果您在檢查If (ActiveWindow.RangeSelection.Rows.count < 4000) Then之后推遲/移動新工作簿的創建，您可以完全擺脫created的變量嗎？ 從邏輯上講，我認為這意味着只有在If條件為True時才會創建新工作簿。

---

我沒有測試下面的代碼，但是如果你在運行過程Macro1之前復制你的工作/文件，那么它可能會給你一些關於如何實現你想要的想法的想法。 它不會與您的代碼完全相同，因為我刪除了一些內容。

您可以使用F8或Shift+F8逐行瀏覽它。 使用F9設置斷點也很有用。

Private Function AddSheetToWorkbook(ByVal targetBook As Workbook, ByVal sheetName As String, Optional sheetIndexToUse As Long = 0) As Worksheet
    ' Either adds a new worksheet or uses existing sheet if sheetIndexToUse was provided.

    Dim targetSheet As Worksheet
    If sheetIndexToUse < 1 Then
        Set targetSheet = targetBook.Worksheets.Add
    Else
        Set targetSheet = targetBook.Worksheets(sheetIndexToUse) ' Will raise error if sheetIndex > Worksheets.Count
    End If
    targetSheet.Name = sheetName

    Set AddSheetToWorkbook = targetSheet
End Function

Private Function CreateAllSheet(ByVal targetBook As Workbook) As Worksheet
    Set CreateAllSheet = AddSheetToWorkbook(targetBook, sheetName:="ALL", sheetIndexToUse:=1)
End Function

Private Function CreateAdviserSheet(ByVal targetBook As Workbook, ByVal Adviser As String) As Worksheet
    Set CreateAdviserSheet = AddSheetToWorkbook(targetBook, sheetName:=Adviser)
End Function

Private Function CreateCountSheet(ByVal targetBook As Workbook) As Worksheet
    Set CreateCountSheet = AddSheetToWorkbook(targetBook, sheetName:="Count")
End Function

Private Function GetLastRow(ByVal targetSheet As Worksheet, Optional ByVal columnToUse As Variant = "A") As Long
    GetLastRow = targetSheet.Cells(targetSheet.Rows.Count, columnToUse).End(xlUp).Row
End Function

Private Function GetLastColumn(ByVal targetSheet As Worksheet, Optional ByVal rowToUse As Long = 1) As Long
    GetLastColumn = targetSheet.Cells(rowToUse, targetSheet.Columns.Count).End(xlToRight).Column
End Function

Private Function GetLastCell(ByVal targetSheet As Worksheet) As Range
    Dim lastRow As Long
    lastRow = GetLastRow(targetSheet)

    Dim lastColumn As Long
    lastColumn = GetLastColumn(targetSheet)

    Set GetLastCell = targetSheet.Cells(lastRow, lastColumn)
End Function

Private Function GetRowsMatchingCriteria(ByVal targetSheet As Worksheet, ByVal targetField As Long, ByVal Criterion As String)
    Dim includingHeaders As Range
    Set includingHeaders = targetSheet.Range("A1", GetLastCell(targetSheet))

    With includingHeaders
        .AutoFilter
        .AutoFilter Field:=targetField, Criteria1:=Criterion

        On Error Resume Next
        Set GetRowsMatchingCriteria = .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0

        .AutoFilter
    End With
End Function

Private Function GetRowsMatchingDept(ByVal targetSheet As Worksheet, ByVal Dept As String) As Range
    Set GetRowsMatchingDept = GetRowsMatchingCriteria(targetSheet, targetField:=60, Criterion:=Dept)
End Function

Private Function GetRowsMatchingAdviser(ByVal targetSheet As Worksheet, ByVal Adviser As String) As Range
    Set GetRowsMatchingAdviser = GetRowsMatchingCriteria(targetSheet, targetField:=61, Criterion:=Adviser)
End Function

Private Sub AdjustRowAndColumnWidths(ByVal targetSheet As Worksheet)
    With targetSheet.Range("A1", GetLastCell(targetSheet))
        .RowHeight = 12.75
        .EntireColumn.AutoFit
    End With
End Sub

Private Sub SortSheetContents(ByVal targetSheet As Worksheet)
    'sort records by dept, then by adv_name, then by id
    With targetSheet
        .Range("A2").Sort Key1:=.Range("BH1"), _
            Key2:=.Range("BI1"), Key3:=.Range("C1"), _
            Header:=xlYes
    End With
End Sub

Private Sub CopyDataToSheetAndFormat(ByVal rangeToCopy As Range, ByVal topLeftPasteCell As Range)
    ' Copies data to a sheet, formats and sorts.
    Dim destinationSheet As Worksheet
    Set destinationSheet = topLeftPasteCell.Parent

    rangeToCopy.Copy Destination:=topLeftPasteCell
    AdjustRowAndColumnWidths targetSheet:=destinationSheet
    SortSheetContents targetSheet:=destinationSheet
End Sub

Private Sub AddBordersToAdviserSheet(ByVal adviserSheet As Worksheet)
    'place the neccessary borders (seperators)
    '31 is the number of the Major_code column
    Const MAJOR_CODE_COLUMN_INDEX  As Long = 31

    Dim lastRow As Long
    lastRow = GetLastRow(adviserSheet, MAJOR_CODE_COLUMN_INDEX)

    With adviserSheet
        Dim targetRange As Range
        Set targetRange = .Range(.Cells(2, MAJOR_CODE_COLUMN_INDEX), .Cells(lastRow, MAJOR_CODE_COLUMN_INDEX))
    End With
    Debug.Assert targetRange.Columns.Count = 1

    Dim cell As Range
    For Each cell In targetRange
        If cell.Value <> cell.Offset(1).Value Then
            ' Might be better to work from sheet's last column to left
            ' or working out last column before entering loop.
            adviserSheet.Range(cell, cell.End(xlToRight)).Borders(xlEdgeBottom).Weight = xlMedium
        End If
    Next cell
End Sub

Private Function GetDataWorksheet() As Worksheet
    Dim folderPath As String
    folderPath = ThisWorkbook.Path & "\"

    Dim dataWorkbook As Workbook
    Set dataWorkbook = Workbooks.Open(folderPath & "data_file.xls", ReadOnly:=True)

    ' Not sure if it is the only sheet in the workbook or not.
    ' If possible, refer to sheet by sheet name.
    Set GetDataWorksheet = dataWorkbook.Worksheets(1)
End Function

Private Function GetAdviserCountsWorksheet() As Worksheet
    Dim targetBook As Workbook
    ' This will raise an error (if book is not already open) so maybe
    ' provide a full path instead.
    Set targetBook = Application.Workbooks("adviser counts (1 & 2).xls")
    Set GetAdviserCountsWorksheet = targetBook.Worksheets("Sheet3")
End Function

Private Function GetAdviserRangeInPivotTable(ByVal adviserCountsSheet As Worksheet, ByVal Dept As String)
    ' There are probably better ways of doing this (e.g. interacting with the
    ' PivotTable's properties/methods -- rather than just iterating over a range)

    Dim lastRow As Long
    lastRow = GetLastRow(adviserCountSheet)

    With adviserCountsSheet
        Dim targetRange As Range
        Set targetRange = .Range("A3", .Cells(lastRow, "A"))

        Dim startRowIndex As Variant
        startRowIndex = Application.Match(Dept, targetRange, 0)

        Dim endRowIndex As Variant
        endRowIndex = Application.Match(Dept & " Total", targetRange, 0)

        Debug.Assert IsNumeric(startRowIndex)
        Debug.Assert IsNumeric(endRowIndex)
        Debug.Assert endRowIndex > startRowIndex

        Set GetAdviserRangeInPivotTable = .Rows(startRowIndex & ":" & endRowIndex)
    End With
End Function

Private Sub ReorderSheets(ByVal targetWorkbook As Workbook)
    ' Moves "ALL" to first, "Count" to second. Does not check if
    ' sheets exist. Will raise an error (if they do not).
    Dim allSheet As Worksheet
    Set allSheet = targetWorkbook.Worksheets("ALL")

    Dim countSheet As Worksheet
    Set countSheet = targetWorkbook.Worksheets("Count")

    allSheet.Move Before:=targetWorkbook.Worksheets(1)
    countSheet.Move After:=allSheet
End Sub

Private Sub FinaliseAndSaveWorkbook(ByVal targetWorkbook As Workbook, ByVal Dept As String)
    ReorderSheets targetWorkbook

    Dim outputFilePath As String
    outputFilePath = ThisWorkbook.Path & "\" & Dept

    ' Currently code does not check if parent folder exists
    ' and whether filename only contains legal characters.

    targetWorkbook.SaveAs Filename:=outputFilePath ' Do you want to specify a file format here too?

End Sub

Sub Macro1()

    Dim dataSheet As Worksheet
    Set dataSheet = GetDataWorksheet()

    Dim adviserCountsSheet As Worksheet
    Set adviserCountsSheet = GetAdviserCountsWorksheet()

    Dim created As Integer
    created = 1

    Dim Dept As Range
    For Each Dept In dataSheet.Columns(1).Cells
        If (Dept.Text = "") Then Exit For

        ' Might be possible to restructure such that you no longer
        ' need the "created" variable.
        If (created = 1) Then
            Dim newWorkbook As Workbook ' Needs a better name
            Set newWorkbook = Application.Workbooks.Add
        End If

        Dim cellsToCopy As Range
        Set cellsToCopy = GetRowsMatchingDept(ThisWorkbook.Worksheets("Sheet1"), Dept.Text)
        Debug.Assert Not (cellsToCopy Is Nothing)

        created = 0

        If cellsToCopy.Columns(1).Cells.CountLarge < 4000 Then
            Dim allSheet As Worksheet
            Set allSheet = CreateAllSheet(newWorkbook)

            CopyDataToSheetAndFormat cellsToCopy, allSheet.Range("A1")

            Dim Adviser As Range
            For Each Adviser In dataSheet.Columns(2).Cells
                If (Adviser.Text = "") Then Exit For

                Set cellsToCopy = GetRowsMatchingAdviser(ThisWorkbook.Worksheets("Sheet1"), Adviser.Text)

                If cellsToCopy.Columns(1).Cells.CountLarge < 1500 Then
                    Dim adviserSheet As Worksheet
                    Set adviserSheet = CreateAdviserSheet(newWorkbook, Adviser.Text)

                    CopyDataToSheetAndFormat cellsToCopy, adviserSheet.Range("A1")
                    AddBordersToAdviserSheet adviserSheet

                    Set adviserSheet = Nothing
                End If
            Next Adviser

            ' This sub will add the sheet Count to each workbook it will simply copy paste from
            ' the pivot table of the adviser distribution

            Dim countSheet As Worksheet
            Set countSheet = CreateCountSheet(newWorkbook)

            adviserCountsSheet.Rows("1:2").Copy countSheet.Range("A1")

            Set cellsToCopy = GetAdviserRangeInPivotTable(adviserCountsSheet, Dept:=Dept.Text)
            cellsToCopy.Copy countSheet.Range("A3")

            FinaliseAndSaveWorkbook newWorkbook, Dept:=Dept.Text
            newWorkbook.Close

            created = 1
        End If

    Next Dept

    dataSheet.Parent.Close
End Sub

這里的主要內容是盡可能明確（當提到workbooks 、 worksheets 、 ranges 、 cells等時）——而不是依賴或假設您想要的 object 將處於活動狀態。