excelmacros如果单元格值不同，则为new sheeet

我有下面的代码，看看B列，并确定是否应该复制到一个新的单元格，或者如果它应该移动到下一行，根据条件。 我想要做的是首先查看A列中的员工姓名，如果第k行中的姓名与第k-1行中的姓名不同，则创build一个新工作表，将行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` 

如果任何人至less可以告诉我在哪里我可以得到一个基于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 ，则会创build一个。
不知道这是否有帮助，但试试看。

Answer 2

所以，如果我读了这个权利，那么你想要有员工列A，B列有你想用来比较的东西，C列是库存types。 如果是这样的话，并且如果这个表在雇员列上sorting，那么下面的修改你应该做的伎俩。

 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 

如果你不能按员工分类……那么这有点棘手。 您必须添加一个函数来search表单名称，以查看该表单是否已经存在，然后find该表单上的位置，然后粘贴到该表单上。 如果你能分类，它会使你的生活变得更容易。