Question

我正在尝试编写（实际修改：））宏以执行以下操作；

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

宏无法正常工作；
-有时宏会运行到最后，但数据尚未填充到文件中。
-有时数据会填充到某些文件，而不是所有文件。

下面是我的代码（已修改，原始内容来自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

Excel VBA宏无法按预期工作

1 个答案: