Excel 使用匹配的数字前缀添加新图纸

在下面，我尝试在工作表中基于MainSheet中的第3列创建新选项卡（如果它们还不存在）。我认为下面应该这样做，但我不知道如何根据匹配的号码前缀对MainSheet中的行进行分组。。。。也就是说，210422-C是单元格，提取后的2104与下面的行匹配。因此，这两行将被复制到一个名为04-21的新选项卡（与提取的前缀相反，在第二个数字后用-分隔）。210505-C是单元格，提取后的2105与下面的行匹配。因此，这两行将被复制到一个名为05-21的新选项卡（与提取的前缀相反，在第二个数字后用-分隔）。不会总是有两行匹配，并且每行中有多个列。谢谢：）

主页

header row
12  aaaa    210422-C    bbb
12  abaa    210429-C    bbb
12  caaa    210505-C    bbb
12  dddd    210511-C    bbb

所需的

04-21

header row
12  aaaa    210422-C    bbb
12  abaa    210429-C    bbb

header row
12  caaa    210505-C    bbb
12  dddd    210511-C    bbb

05-21

header row
12  aaaa    210422-C    bbb
12  abaa    210429-C    bbb

header row
12  caaa    210505-C    bbb
12  dddd    210511-C    bbb

VBA

Private Sub 
CommandButton1_Click() 
Dim MainSheet As Worksheet
Dim NewSheet As Worksheet
Dim myBook As Workbook
Dim lastRow As Long
Dim i As Long
Dim namesColumn

'Define workbook - here set as the active workbook
Set myBook = ActiveWorkbook

'Define worksheets - The sheets are named "MainSbeet"
Set masterSheet =
myBook.Worksheets("MainSheet")

'Define which column in your master tab to search
 namesColumn = 3

'Find the last row of the sheets list
 lastRow = MainSheet.Cells(MainSheet.Rows.Count, namesColumn).End(xlUp).Row

'Cycle through the list - Assuming header row and starts in column "A" from the 2nd row
For i = 2 To lastRow
    With myBook
'Define new sheet
    Set NewSheet = .Worksheets.Add(After:=.Worksheets("MainSheet"))
 End With

'Find name of the tab and naming the tab
tabName = masterSheet.Cells(i, namesColumn)
     NewSheet.Name = tabName

'Copy from MainSheet  MainSheet.ActiveCell.EntireRow.Select.Copy _
      Destination:=NewSheet.ActiveCell.EntireRow.Select

'Paste in e.g. cell A1 i.e. (1,1) the tab name
NewSheet.Cells(1, 1).Value = tabName

'Only add sheet if it doesn't exist already and the name is longer than zero characters
If (Sheet_Exists(NewSheet) = False) And (NewSheet <> "") Then
 Worksheets.Add().Name = NewSheet
End If

Next i
End Sub

Private Sub
CommandButton1_单击（）
将主工作表调整为工作表
将新闻纸变暗为工作表
将myBook设置为工作簿
最后一排一样长
我想我会坚持多久
Dim名称列
'定义工作簿-此处设置为活动工作簿
设置myBook=ActiveWorkbook
'定义工作表-工作表名为“MainSbeet”
定稿=
myBook.工作表（“主表”）
'在主选项卡中定义要搜索的列
名称列=3
'查找工作表列表的最后一行
lastRow=MainSheet.Cells（MainSheet.Rows.Count，namesColumn）。End（xlUp）。Row
'在列表中循环-假设标题行，并从第2行的“A”列开始
对于i=2到最后一行
用我的书
'定义新工作表
设置新闻表=.Worksheets.Add（在：=.Worksheets（“主工作表”）之后）
以
'查找选项卡名称并命名选项卡
tabName=母版纸.单元格（i，名称列）
NewSheet.Name=tabName
'从MainSheet MainSheet.ActiveCell.EntireRow.Select.Copy复制_
目标：=NewSheet.ActiveCell.EntireRow.Select
'粘贴在单元格A1中，即（1,1）选项卡名称
NewSheet.Cells（1，1）.Value=tabName
'仅当工作表不存在且名称长度超过零个字符时才添加工作表
如果（工作表_存在（新闻表）=False）和（新闻表“”），则
Worksheets.Add（）.Name=新闻纸
如果结束
接下来我
端接头

一旦您理解了逻辑，它实际上非常简单

逻辑：

确定你的范围

获取数组中的范围

循环遍历数组并提取左4个字符，然后创建一个唯一的集合。这也将帮助我们确定需要创建的图纸数量

在集合中循环并创建图纸

将标题从主图纸复制到新创建的图纸

在同一循环中，根据集合中的4个字符过滤主工作表中的数据，并复制到新创建的工作表中。有关此方法的更多信息，请参见

代码：

我已经对代码进行了注释，但是如果您仍然面临任何问题，只需问：）

正在运行：

注意：

以上代码现在考虑了@chrisneilsen提出的合理问题

如果已经存在具有该名称的工作表，则它将使用该名称，而不会创建新工作表

如果工作表存在并且有数据，则数据将添加到末尾。我已经在上面的截图中显示了这一点。如果要覆盖数据，只需在查找最后一行之前清除第2行的数据，然后再查找最后一行

lRow=wsNew.Range（“A”&wsNew.Rows.Count）。End（xlUp）。row+1

图纸名称按要求颠倒

---

遍历数据并测试工作表名称可能是最简单的方法

Private Sub SplitTable() 'CommandButton1_Click()
    Dim wsSrc As Worksheet: Set wsSrc = ThisWorkbook.Worksheets("MainSheet")
    Dim wsLastRow As Long: wsLastRow = wsSrc.Range("A1").CurrentRegion.Rows.count
    Dim i As Long, wsDest As Worksheet, wsName As String
    
    With wsSrc
        For i = 2 To wsLastRow
            wsName = Mid(.Cells(i, 3), 3, 2) & "-" & Left(.Cells(i, 3), 2)
            If Not WorkSheetExists(wsName, ThisWorkbook) Then
                ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count)).Name = wsName
                .Rows(1).EntireRow.Copy Destination:=ThisWorkbook.Worksheets(wsName).Rows(1)
            End If
            Set wsDest = ThisWorkbook.Worksheets(wsName)
            .Rows(i).EntireRow.Copy Destination:=wsDest.Rows(wsDest.Range("A1").CurrentRegion.Rows.count + 1)
        Next i
    End With
End Sub

Private Function WorkSheetExists(ByVal SheetName As String, ByRef TargetWorkbook As Workbook) As Boolean
   On Error Resume Next
   WorkSheetExists = Not TargetWorkbook.Worksheets(SheetName) Is Nothing
End Function

---

我目前无法给出答案，但是，您的代码的结果是什么？它与您期望的结果有何不同？编辑您的问题以解决此问题。非常感谢你们，这些评论非常有用：）。