拆分的新表生成新序号

hhxq001 · 发表于 2023-5-15 17:25

在本论坛找到了一段汇总表拆分成分表的代码，实现了拆分，但序号还是原序号。要求拆分后，分表的序号列重新产生从1-n的顺序号，怎么实现

00-汇总表拆开--自动序号问题.zip (166.93 KB, 下载次数: 13)

3190496160 · 发表于 2023-5-15 17:53

00-汇总表拆开--自动序号问题.rar (144.28 KB, 下载次数: 10)

hhxq001 · 发表于 2023-5-15 18:20

3190496160 发表于 2023-5-15 17:53

好像每次都生成一个“空值”工工作簿，怎么才能不让它生成呢

绝世梦想 · 发表于 2023-5-15 18:48

增加两行代码即可
ActiveSheet.Columns("a:c").NumberFormat = "@"
         ActiveSheet.Columns("e:i").NumberFormat = "@"

         ActiveSheet.Range("A2").Resize(UBound(brr, 2), UBound(brr)) = Application.Transpose(brr)



         ActiveSheet.Range("J2") = "=Row()- 1"
         ActiveSheet.Range("J2:J" & ActiveSheet.[A65536].End(xlUp).Row).FillDown

绝世梦想 · 发表于 2023-5-15 19:29

hhxq001 发表于 2023-5-15 18:20
好像每次都生成一个“空值”工工作簿，怎么才能不让它生成呢

Private Sub CommandButton19_Click()

'选择以哪个列为工作簿名称，选择哪个列为工作表名称
Application.DisplayAlerts = False

Dim ARR, brr()
Dim bkk, shh, bk, sh, Rngh
Dim d1, d2, i, k1, k2, j, k
Dim n, m, ab
bkk = Application.InputBox("请输入拆分成的新工作簿名称所在的列:", "工作簿名称所在列", "F", Type:=2)
If bkk = "" Then Exit Sub
shh = Application.InputBox("请输入拆分成的新工作表名称所在的列:", "工作表名称所在列", "G", Type:=2)
If shh = "" Then Exit Sub
bk = Cells(1, bkk).Column
sh = Cells(1, shh).Column
Set Rngh = Rows(1) '标题
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
ARR = [A1].CurrentRegion '数据写入数组
  For i = 2 To UBound(ARR)
  d1(Replace(ARR(i, bk), Chr(9), "")) = "" '第bk列去重
  d2(Replace(ARR(i, sh), Chr(9), "")) = "" '第sh列去重
  Next
k1 = d1.Keys '第bk列去重后的集合
k2 = d2.Keys '第sh列去重后的集合

For i = 0 To d1.Count - 2
  With Workbooks.Add(xlWBATWorksheet) '按照第2列新建工作簿
If k1(i) <> "" Then
      '.SaveAs FileName:=ThisWorkbook.Path & "\" & "空值" & ".xlsx" '另存为工作簿并命名
   'Else
.SaveAs FileName:=ThisWorkbook.Path & "\" & k1(i) & ".xlsx" '另存为工作簿并命名
End If
  End With

   For j = 0 To d2.Count - 1
      For k = 2 To UBound(ARR)
         If Replace(ARR(k, bk), Chr(9), "") = k1(i) And Replace(ARR(k, sh), Chr(9), "") = k2(j) Then '筛选满足第bk列和第sh列条件的数据
            n = n + 1
            ReDim Preserve brr(1 To UBound(ARR, 2), 1 To n)
               For m = 1 To UBound(ARR, 2)
                     brr(m, n) = Replace(ARR(k, m), Chr(9), "") '写入数组brr
               Next m
            End If
      Next k
      If n > 0 Then
            If k2(j) <> "" Then
               'Sheets.Add.Name = "空值"
               'Else
               Sheets.Add.Name = k2(j) '新增工作表

            End If
         Rngh.Copy ActiveSheet.Range("A1") '把标题写入第一行

         ActiveSheet.Columns("a:c").NumberFormat = "@"
         ActiveSheet.Columns("e:i").NumberFormat = "@"

         ActiveSheet.Range("A2").Resize(UBound(brr, 2), UBound(brr)) = Application.Transpose(brr)
         r = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row
         If r >= 2 Then
               For s = 2 To r
                  ActiveSheet.Cells(s, 10) = s - 1
            Next s
         End If
         'ActiveSheet.Cells.EntireColumn.AutoFit '所有列自动列宽
         ActiveSheet.Range("a:h").EntireColumn.AutoFit 'a-h列自动列宽
         'ActiveSheet.Rows(2).Columns.AutoFit
         ActiveSheet.[d1].ColumnWidth = 9.5    'd列列宽9.5

         ab = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
         ActiveSheet.Range("a2:j" & ab).Borders.LineStyle = xlContinuous '表加表格线
         ActiveSheet.Range("A2:j" & ab).ShrinkToFit = True '自动缩小字体
         ActiveSheet.Range("A2:H" & ab).RowHeight = 17.25 '行宽
         Erase brr
         n = 0
      End If
Next j
   Sheets("sheet1").Delete
   ActiveWorkbook.Close True '关闭保存
Next i
Set d1 = Nothing
Set d2 = Nothing
Application.DisplayAlerts = True
End Sub

绝世梦想 · 发表于 2023-5-15 19:46

序号重新生成并不产生空值表

hhxq001 · 发表于 2023-5-15 20:28

hhxq001 发表于 2023-5-15 18:20
好像每次都生成一个“空值”工工作簿，怎么才能不让它生成呢

没明白为什么要产生一个空值文件

3190496160 · 发表于 2023-5-15 20:43

hhxq001 发表于 2023-5-15 18:20
好像每次都生成一个“空值”工工作簿，怎么才能不让它生成呢

只能是根据你的需求修改代码，没有情趣去研究你的代码的，感觉，目前的代码就是非常低端的，

zxsea_7426 · 发表于 2023-5-15 21:41

看原码很头疼，重新写了一个：

hhxq001 · 发表于 2023-5-15 22:13

zxsea_7426 发表于 2023-5-15 21:41
看原码很头疼，重新写了一个：

佩服的五体投地啊

		自动登录	找回密码
密码			免费注册

[求助] 拆分的新表生成新序号

评分

评分

评分