Copy Access table data to Excel sheet

Question

I am trying to copy tables from an Access database to an Excel sheet named "ALL". The sheet remains blank.

The data is being appended in a sheet named "count" where there is a pivot table.

I spent three days exploring this but didn't find the solution.

     ' 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
     

I expect the output of all sheets to appear in sheet "ALL" and counts sheet to contain only its pivot table.

Answer 1

This line here:

ActiveSheet.Name = "ALL"

is renaming the current active sheet to be 'ALL'. You should consider changing that line to select the sheet instead like so:

Worksheets("ALL").Activate

or

Sheets("ALL").Select

Answer 2

This section:

         ' 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

doesn't make sense (to me at least).

• You're looking for some sheet whose name is between "Sheet:0" and "Sheet:20". But (assuming I've understood the preceding code) the workbook (named new_wb) at that moment will only contain 2 sheets; namely ALL and whatever Adviser.Text evaluated to.
• If the condition inside the For loop is always False, your code won't activate the worksheet you want to paste to -- meaning you'll probably proceed to paste to whichever worksheet was active before the For loop.
• It would be good to put this section into a function which returns a worksheet. That way it returns either a Worksheet or Nothing -- and the possibility of it silently failing is removed.
• You declare variables A1 and A2, but inside both For loops you only use A2. Maybe this is deliberate or maybe you copy-pasted and forgot to update.

---

• created seems to be a flag indicating whether or not to create a new workbook during the current loop iteration. It only seems to be one of two values throughout the code (1 or 0), so it might be better declared as type Boolean.
• However, if you defer/move the creation of the new workbook after the check If (ActiveWindow.RangeSelection.Rows.count < 4000) Then, can you get rid of the created variable completely? Logically I think it would mean a new workbook only gets created if the If condition is True.

---

I've not tested the code below, but if you make copies of your work/files before running procedure Macro1, then it might give you some idea on how to achieve what you want. It won't be exactly the same as your code, as there were some things I removed.

You can step through it line by line with F8 or Shift+F8. Setting breakpoints with F9 is useful too.

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

The main takeaway here is to be as explicit as possible (when referring to workbooks, worksheets, ranges, cells, etc.) -- and not rely on, or assume, that the object you want will be active.