Question

我有下面的代码，它将在B列中查找并确定是否应该将行复制到新单元格，或者是否应该根据条件将其移动到下一行。我想要它做的是首先查看列A，员工姓名，如果行k中的名称与行k-1中的名称不同，则创建一个新工作表，将行k复制到那里然后循环周围。最终，每个员工都有自己的工作表。

Sub Sample()

Dim myarray

Dim wsInv As Worksheet
Dim rngDes As Range, rng As Range, cel As Range
Dim k As Long

Set wsInv = Thisworkbook.Sheets("Inventory")
Set rng = wsInv.Range("A2", wsInv.Range("A" & Rows.Count).End(xlup).Address)
Set rngDes = Thisworkbook.Sheets("Sheet3").Range("A3")

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")

k = 0
For Each cel in rng
    If cel.Value = cel.Offset(-1,0).Value Then
        If Not IsError(Application.Match(cel.Offset(0,1).value, myarray, 0)) Then  
            cel.EntireRow.Copy rngDes.Offset(k,0)
            k = k + 1
        End If
    End If
Next cel`

如果有人至少能告诉我在哪里可以根据A栏值找到新表，那就太棒了，谢谢

Answer 1

如评论所述，试试这个：

   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

        If wsDes Is Nothing Then Set wsDes = ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))

        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

以上代码的作用是检查Column B中的值是否在数组中如果是，它会将数据复制到以员工命名的Sheet 如果该员工尚未拥有Sheet，则会创建一个不确定这是否有帮助，但试一试。

Answer 2

因此，如果我读得正确，那么您希望列A包含员工，列B包含您要用于比较的内容，列C包含库存类型。如果是这种情况，并且如果此表在employees列上排序，则对您所拥有的内容进行以下修改应该可以解决问题。

k = 0
Dim currentSheet as Worksheet, currentName as String
For Each cel in rng
    'So if column a contains names, 
    'and the name isn't what we have as the current name...
    If currentName <> cel.Value Then
         'reset your counter and your "currentSheet"
         k = 0
         Set currentSheet = ThisWorkbook.Sheets.Add
         currentSheet.Name = Left(rng.Value,31)
    End If
    'So as I read your original code, you had your search criteria in column
    'A. I am assuming employee name is now in column A and everything else
    'is shifted over, hence why the additional offset and why the other offset values 
    'have been changed
    If cel.Offset(,1).Value = cel.Offset(-1,1).Value Then
        If Not IsError(Application.Match(cel.Offset(0,2).value, myarray, 0)) Then  
            'This code also copies employee name, I don't know if that is 
            'desired or not. I am thinking if you don't need employee name,
            'the easiest thing to do would be to delete column A in the new sheets
            'in the above if block before you assign a new currentSheet
            cel.EntireRow.Copy currentSheet.Offset(k,1)
            k = k + 1
        End If
    End If
Next cel

如果你不能按员工排序......那就有点棘手了。您必须添加一个功能，搜索工作表名称以查看该工作表是否已存在，然后在该工作表上找到您停止的位置，然后粘贴到那里。如果你可以分类，它会让你的生活变得更轻松。

excel宏如果单元格值不同，则为新工作表

2 个答案: