为什么此VBA代码在Access上不起作用？

Question

i有一个代码，该代码按特定的列值拆分数据，从而使用值名称创建新的工作表。该代码在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 ---您可能需要使用exapp.Evaluate(...)来使Excel特定于。）>

Answer 2

由于我发布的代码是从网络上获取的，因此我重新编写了代码以使其更加清晰。现在工作完美！这段代码假设第一行中有一个标头，该标头将被复制到每个新工作表中，而要拆分的数据在第二列中。尽管您可以更轻松地添加输入框，但用户可以选择标题和列。