Excel VBA 宏无法按预期工作

Question

我正在尝试编写（实际修改:)）一个宏来执行以下操作；

1. 根据特定列（在本例中为第 1 列）中的每个值过滤数据
2. 复制/填充过滤后的数据（在这个数组中）
3. 粘贴到特定工作簿的特定工作表中（我需要将此过滤后的数据粘贴到我的硬盘上可用的文件中，该文件与我用于过滤数据的名称相同）
4. 保存文件并关闭文件。

宏未按预期工作；
- 有时宏运行结束，但数据尚未填充到文件中。
- 有时数据填充到某些文件但不是所有文件。

以下是我的代码（修改后，原始代码来自 Stack Overflow）。谢谢！

Sub parse_data()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    Dim Name As String
    Dim SheetName As String

    ' Getting the worksheet name which filtered data to be pasted.
    SheetName = InputBox("Please enter the name of experiment")

    'The column number of Splitting data based on
    vcol = 1

    'The base sheet name
    Set ws = Sheets("Total")
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row

    'Range of table headings
    title = "A1:K1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"

    For i = 2 To lr

        On Error Resume Next

        If ws.Cells(i, vcol) <> "" And Application.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 = Application.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
            'Open data sheets which filtered data to be copied
            Workbooks.Open ("C:\Users\\Findings\" & myarr(i) & ".xlsm")
            Worksheets(SheetName).Activate
            ActiveWorkbook.LockServerFile
        End If
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(SheetName).Range("A1")
        Sheets(SheetName).Columns.AutoFit

        ActiveWorkbook.Save
        Application.DisplayAlerts = False
        ActiveWorkbook.Close
        Application.DisplayAlerts = True
    Next
    ws.AutoFilterMode = False
    ws.Activate
End Sub

Answer 1

尝试这种方式来修复使用的文件/工作表的波动性：

Option Explicit
dim fout as workbook
dim sout as worksheet
on error goto 0
For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
        'Open data sheets which filtered data to be copied
        set fout=Workbooks.Open ("C:\Users\\Findings\" & myarr(i) & ".xlsm")
        if fout is nothing then goto errorhandler
        set sout=fout.Worksheets(SheetName)
        if sout is nothing then goto errorhandler
        fout.LockServerFile
        if err.number <>0 then goto errorhandler
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy sout.Range("A1")
        sout.Columns.AutoFit

        Application.DisplayAlerts = False
        fout.Close true            ' save & close
        Application.DisplayAlerts = True
        set fout=nothing
        set sout=nothing
    End If
Next