时间戳

首页 > 解决方案 > 如何从 Access 数据库中按 Excel 工作簿的列拆分数据

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

问题描述

我有一个代码，它按特定列值拆分数据，创建具有值名称的新工作表。该代码在 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 文件只是打开并开始过滤/滚动而不创建新工作表。

标签： excelvbams-accessautomation

解决方案

(A) “我没有收到任何错误”是预期的，因为您的代码使用On Error Resume Next. 最好的做法是限制On Error Resume Next从一小段代码中捕获潜在错误，然后立即使用On Error Goto 0.

(B) 另外，我认为 Access 没有Evaluate--- 您可能需要使用exapp.Evaluate(...).

推荐阅读