根据表

Question

我想有一个可以读取表值的宏，如果匹配则将行复制到相应的名称工作表。

假设我有一个模板和Sheet1工作表。 （无法嵌入图片） Sheet1 Table

'template'工作表是如果列F值与Sheet1中的ID之一匹配的源，它将被复制到相应的组（工作表） 示例 - 模板F列中包含123的所有行都将复制到“North”工作表。

我已经修改了excel母版提供的部分代码。 但是，在此代码UpdateWs ws(wsTosaveto), ur

中抛出错误“对象变量或未设置块变量”

任何帮助将不胜感激..

Sub sliceNdice()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Const master_ws As String = "template"
    Const master_col As String = "F"    'AutoFilter column in Master sheet

    Dim OldBook As Workbook
    Dim LastRow As Long, i As Long
    Dim valuetoFind As String, wsTosaveto As String
    Dim ws As Worksheet, lr As Long, lc As Long, ur As Range, fCol As Range, done As Range
    Dim wb As Workbook
    Set wb = Application.ThisWorkbook

    With wb.Worksheets(master_ws)
        lr = .Cells(.Rows.Count, master_col).End(xlUp).Row   'find last row of template
        lc = .Cells(1, .Columns.Count).End(xlToLeft).Column  'find last column template
        Set ur = .Range(.Cells(3, 1), .Cells(lr, lc))  'set the range of data
        Set fCol = .Range(.Cells(2, master_col), .Cells(lr, master_col))
        Set done = .Range(.Cells(1, master_col), .Cells(2, master_col))
    End With


    Set OldBook = ThisWorkbook
    'Find last row of Sheet1 table
    LastRow = OldBook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

    'Scan all rows of Sheet1 table
    For i = 3 To LastRow 'Start in third row. First 2 row for titles
      valuetoFind = OldBook.Worksheets("Sheet1").Cells(i, 1).Value
      wsTosaveto = OldBook.Worksheets("Sheet1").Cells(i, 2).Value

      fCol.AutoFilter Field:=1, Criteria1:=valuetoFind
        If fCol.SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
          UpdateWs ws(wsTosaveto), ur
          Set done = Union(done, fCol.SpecialCells(xlCellTypeVisible))
        End If
    Next i

    If wb.Worksheets(master_ws).AutoFilterMode Then
      fCol.AutoFilter
      UpdateNA done, ur
    End If
    Application.ScreenUpdating = True
End Sub


Private Sub UpdateWs(ByRef ws As Worksheet, ByRef fromRng As Range)
    fromRng.Copy
    With ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0)
        .PasteSpecial xlPasteAll
    End With
    ws.Activate
    ws.Cells(1).Select
End Sub

Private Sub UpdateNA(ByRef done As Range, ByRef ur As Range)
    done.EntireRow.Hidden = True
    If ur.SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
        UpdateWs ThisWorkbook.Worksheets(NA_WS), ur.SpecialCells(xlCellTypeVisible)
    End If
    done.EntireRow.Hidden = False
    Application.CutCopyMode = False
    ur.Parent.Activate

End Sub