Как разделить данные по столбцам книг Excel из базы данных Access

Question

У меня есть код, который разбивает данные по определенному значению столбца, создавая новые листы с именем значенияКод прекрасно работает в Excel VBA, хотя я хотел использовать его из Access и управлять внешней книгой, которую пользователь выбирает через FileDialog. Я запускаю некоторый тест, вставляя путь к файлам Excel, которые я хочу разделить, но он работает ТОЛЬКО В ПЕРВЫЙ РАЗ, даже если я ухожу без сохранения, он больше не работает. Вот код (я сделал некоторые изменения для ссылки на Excel):

Dim lr As Long
Dim ws As Excel.Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim xTRg As Excel.Range
Dim xVRg As Excel.Range
Dim xWSTRg As Excel.Worksheet
Dim wb As Excel.Workbook
Dim exapp As Excel.Application


Set exapp = CreateObject("Excel.Application")
Set wb = exapp.Workbooks.Open("xxx\Desktop\New Microsoft Excel Worksheet.xlsx")
exapp.Visible = True

On Error Resume Next

Set xTRg = wb.ActiveSheet.Range("1:1") 'header (same for all sheets)
Set xVRg = wb.ActiveSheet.Range("B2:B1000") 'range of data to be splitted (i will change for .end(xlup) method)
vcol = xVRg.Column
Set ws = xTRg.Worksheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = xTRg.AddressLocal
titlerow = xTRg.Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
exapp.DisplayAlerts = False
If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then
    wb.Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
Else
    wb.Sheets("xTRgWs_Sheet").Delete
    wb.Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
End If
Set xWSTRg = wb.Sheets("xTRgWs_Sheet")
xTRg.Copy
xWSTRg.Paste Destination:=xWSTRg.Range("A1")
ws.Activate
For i = (titlerow + xTRg.Rows.Count) To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And exapp.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
        ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
Next
myarr = exapp.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
    wb.Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
    wb.Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
    xWSTRg.Range(title).Copy
    wb.Sheets(myarr(i) & "").Paste Destination:=Sheets(myarr(i) & "").Range("A1")
    ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A" & (titlerow + xTRg.Rows.Count))
    wb.Sheets(myarr(i) & "").Columns.AutoFit
Next
    xWSTRg.Delete




ws.AutoFilterMode = False
ws.Activate
exapp.DisplayAlerts = True

Я не получаю никакой ошибки, файл Excel просто открывается и начинает фильтровать / прокручивать без создания новых листов.

Answer 1

(A) "Я не получаю никакой ошибки" ожидается, так как ваш код подавляет ошибки с On Error Resume Next. Рекомендуется ограничить On Error Resume Next отлавливанием потенциальной ошибки из короткого сегмента кода, а затем немедленно включить ошибки с помощью On Error Goto 0.

(B) Кроме того, я не думаю, что Access имеет Evaluate --- вам может потребоваться сделать это для Excel с exapp.Evaluate(...).