Question

我正在使用下面的代码，如果单元格中有一个值，则我会针对一组critera（Array）扫描B列，复制该行，然后将该行带到员工姓名（A列）如果员工没有工作表制作新工作表，请将行放在下一行。

目前的代码是进入第二行（相同员工姓名）并选择尝试制作新工作表而不是添加到现有工作表。

这导致错误，因为它无法制作另一张同名的表格。

`Sub Sample()

Dim myarray

Dim wsInv As Worksheet, wsDes As Worksheet
Dim rngDes As Range, rngEmp As Range, cel As Range

Set wsInv = ThisWorkbook.Sheets("Inventory")
Set rngEmp = wsInv.Range("A2", wsInv.Range("A" & Rows.Count).End(xlUp).Address)

myarray = Array("CONSUMABLES", "FILTERS - BILLI TRIO", "FILTERS - ZIP GENERIC", _
    "GOODS", "HARDWARE FIXINGS", "LIGHTING - 50W DICHROIC", "LIGHTING - COMPACT BC/ES", _
    "LIGHTING - DICHROIC LAMP", "LIGHTING - FLURO", "LIGHTING - PLC LAMP 840/830", _
    "LIGHTING - PL-L", "LIGHTING - PULSE STARTER", "LIGHTING - STANDARD STARTER", _
    "LIGHTING - T5 FLURO", "NITROGEN CHARGE", "OXYGEN / ACETYLENE WELDING", _
    "R-134A", "R-22", "R-407C", "R-410A")

For Each cel In rngEmp
    If Not IsError(Application.Match(cel.Offset(0, 1).Value, myarray, 0)) Then
        On Error Resume Next
        Set wsDes = ThisWorkbook.Sheets(cel.Value)
        On Error GoTo 0
                'Error is here  vvvvv
        If wsDes Is Nothing Then Set wsDes = ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
       'It should just move on but doesnt
        wsDes.Name = cel.Value
        cel(1 - (cel.Row - 1)).EntireRow.Copy wsDes.Range("A1")
        cel.EntireRow.Copy wsDes.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        Set wsDes = Nothing
    End If
Next cel

End Sub`

帮助？请！

为了使wsDes具有值，它等于

ThisWorkbook.Sheets(cel.Value)

当我突出显示这一行时，它会告诉我

ThisWorkbook.Sheets(cel.Value) = <Subscript out of range>

这样就没有什么价值可以制作一张新纸，思绪??

Answer 1

无论是否已创建新工作表，您始终会重命名工作表并复制页眉：您需要关闭if语句

If wsDes Is Nothing Then 
    Set wsDes = ThisWorkbook.Sheets.Add( _
                   after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    wsDes.Name = cel.Value 'now this only runs for new sheets...
    cel(1 - (cel.Row - 1)).EntireRow.Copy wsDes.Range("A1")
End If

Excel宏vba，未使用变量值

1 个答案: