如何从Access数据库中按Excel工作簿的列拆分数据

Question

我有一个代码，它按特定的列值拆分数据，创建具有值名称的新表。该代码在ExcelVBA上运行得很好，尽管我想从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("xxxDesktopNew 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特定。