[已解决]要怎样用VBA拆分合并这样的工作表呢？希望得到老师的帮助！

gcloveu

1，将清单1文件中“报检清单”工作表，按阶段性的合计拆分成清单2那样多个工作表
2，将清单1文件中“认证零件清单”工作表，“非认证零件清单”工作表合并成清单2那样“零件清单”工作表
因为每天都要把客户发来的这样的表格做这样的拆分合并，以变成系统可以识别的格式，所以希望可以用VBA解决，但是试了几次都搞得太复杂，只能在这里求助各位大神了！
清单1.part1.rar (500 KB, 下载次数: 10)

2017-8-30 12:27 上传

点击文件名下载附件
清单1.part2.rar (470.56 KB, 下载次数: 6)

2017-8-30 12:27 上传

点击文件名下载附件
清单2.part1.rar (500 KB, 下载次数: 8)

2017-8-30 12:27 上传

点击文件名下载附件
清单2.part2.rar (239.34 KB, 下载次数: 11)

2017-8-30 12:27 上传

点击文件名下载附件
前两个合在一起是一个文件“清单1”，后两个合在一起是要达到的效果“清单2”，四个文件都要下载

最佳答案

月排行榜 / 总排行榜

0126

2017-8-31 12:12

Sub 拆分()
Dim arr, brr(1 To 100000) As Long, x As Long, k As Long, g As Long
  arr = Sheets("报检清单").UsedRange
  k = 1: brr(1) = Rows.Count: g = Sheets.Count   '给一个最大行数，第一次不删除前面数据：确定工作表个数，
For x = 1 To UBound(arr)                 '判断合计在工作表位置好确定拆分
    If arr(x, 4) = "合计" Then k = k + 1: brr(k) = x
Next
For x = 1 To k - 1     '开始拆分，由于不知道怎么完全复制所以复制整个工作表后删除掉多余部分的方法
   Sheets("报检清单").Copy after:=Sheets(Sheets.Count) '复制整个工作表放在最后一位
   With Sheets(Sheets.Count)
        .Name = "报检清单" & x                             '命名工作表
        .Range(brr(x + 1) + 1 & ":" & brr(k) + 2 & "," & brr(1) & ":" & brr(x)).Delete   '删除前面后面部分
        brr(1) = 4                        '确定拆分数据是在哪行开始,以供删除前面无用的
   End With
Next
  Call 合并
  Call 另存为(g + 1)
End Sub
Sub 合并()
Dim arr, brr, x As Long, k As Long
  arr = Sheets("认证零件清单").UsedRange: brr = Sheets("非认证零件清单").UsedRange
  Sheets("认证零件清单").Copy after:=Sheets(Sheets.Count) '复制整个工作表放在最后一位
  With Sheets(Sheets.Count)
       .Name = "零件清单"                             '命名工作表
       Sheets("非认证零件清单").Range("4:" & UBound(brr)).Copy .Cells(UBound(arr), 1) ' 粘贴第二个工作表
       k = UBound(arr) + UBound(brr) - 1                                  '设置变量简化后面
       .Rows(k - 3 & ":" & k).Insert                                           '插入行
       .Cells(k, 5) = brr(UBound(brr), 5)                            '以下写入后面二行相关数据
       .Cells(k, 8) = brr(UBound(brr), 8)
       .Cells(k + 1, 5) = "=SUM(R[-" & k & "]C:R[-1]C)/2"
       .Cells(k + 1, 8) = "=SUM(R[-" & k & "]C:R[-1]C)/2"
       .PageSetup.PrintArea = "$A$1:$K$" & k + 1                     '显示打印区域
  End With
End Sub
Sub 另存为(yg As Long)
    Dim x As Integer, n(), wb As Workbook, m As Workbook
    Set m = ActiveWorkbook
    ReDim n(0 To Sheets.Count - yg)
    For x = yg To Sheets.Count       '所以工作表名放入数组
     n(x - yg) = Sheets(x).Name
    Next x
      Sheets(n).Move                 '移动数组中名称的工作表
      Set wb = ActiveWorkbook
      If Dir(m.Path & "\" & "清单" & Date & ".xls") = "" Then MsgBox "当前工作表所在路径已有【清单" & Date & "】工作表，请删除或者移动到别的地方": Exit Sub
      wb.SaveAs m.Path & "\" & "清单" & Date & ".xlsx"          '另存为
      wb.Close True            '保存工作表
End Sub

跳转到最佳答案楼层

0126

Sub 拆分()
Dim arr, brr(1 To 100000) As Long, x As Long, k As Long, g As Long
  arr = Sheets("报检清单").UsedRange
  k = 1: brr(1) = Rows.Count: g = Sheets.Count   '给一个最大行数，第一次不删除前面数据：确定工作表个数，
For x = 1 To UBound(arr)                 '判断合计在工作表位置好确定拆分
    If arr(x, 4) = "合计" Then k = k + 1: brr(k) = x
Next
For x = 1 To k - 1     '开始拆分，由于不知道怎么完全复制所以复制整个工作表后删除掉多余部分的方法
   Sheets("报检清单").Copy after:=Sheets(Sheets.Count) '复制整个工作表放在最后一位
   With Sheets(Sheets.Count)
        .Name = "报检清单" & x                             '命名工作表
        .Range(brr(x + 1) + 1 & ":" & brr(k) + 2 & "," & brr(1) & ":" & brr(x)).Delete   '删除前面后面部分
        brr(1) = 4                        '确定拆分数据是在哪行开始,以供删除前面无用的
   End With
Next
  Call 合并
  Call 另存为(g + 1)
End Sub
Sub 合并()
Dim arr, brr, x As Long, k As Long
  arr = Sheets("认证零件清单").UsedRange: brr = Sheets("非认证零件清单").UsedRange
  Sheets("认证零件清单").Copy after:=Sheets(Sheets.Count) '复制整个工作表放在最后一位
  With Sheets(Sheets.Count)
       .Name = "零件清单"                             '命名工作表
       Sheets("非认证零件清单").Range("4:" & UBound(brr)).Copy .Cells(UBound(arr), 1) ' 粘贴第二个工作表
       k = UBound(arr) + UBound(brr) - 1                                  '设置变量简化后面
       .Rows(k - 3 & ":" & k).Insert                                           '插入行
       .Cells(k, 5) = brr(UBound(brr), 5)                            '以下写入后面二行相关数据
       .Cells(k, 8) = brr(UBound(brr), 8)
       .Cells(k + 1, 5) = "=SUM(R[-" & k & "]C:R[-1]C)/2"
       .Cells(k + 1, 8) = "=SUM(R[-" & k & "]C:R[-1]C)/2"
       .PageSetup.PrintArea = "$A$1:$K$" & k + 1                     '显示打印区域
  End With
End Sub
Sub 另存为(yg As Long)
    Dim x As Integer, n(), wb As Workbook, m As Workbook
    Set m = ActiveWorkbook
    ReDim n(0 To Sheets.Count - yg)
    For x = yg To Sheets.Count       '所以工作表名放入数组
     n(x - yg) = Sheets(x).Name
    Next x
      Sheets(n).Move                 '移动数组中名称的工作表
      Set wb = ActiveWorkbook
      If Dir(m.Path & "\" & "清单" & Date & ".xls") = "" Then MsgBox "当前工作表所在路径已有【清单" & Date & "】工作表，请删除或者移动到别的地方": Exit Sub
      wb.SaveAs m.Path & "\" & "清单" & Date & ".xlsx"          '另存为
      wb.Close True            '保存工作表
End Sub

gcloveu

0126 发表于 2017-8-31 12:12
Sub 拆分()
Dim arr, brr(1 To 100000) As Long, x As Long, k As Long, g As Long
  arr = Sheets("报检 ...

太棒了，完全符合要求，谢谢你了！真是高人！

gcloveu

0126 发表于 2017-8-31 12:12
Sub 拆分()
Dim arr, brr(1 To 100000) As Long, x As Long, k As Long, g As Long
  arr = Sheets("报检 ...

如果不另存，在原文件上拆分，合并要怎么做呢？（另：把前两个工作表删除，最后一个工作表保留）

0126

gcloveu 发表于 2017-9-1 09:02
如果不另存，在原文件上拆分，合并要怎么做呢？（另：把前两个工作表删除，最后一个工作表保留）

Call 另存为(g + 1)

不另存就把这个删掉吧，这个是调运行最后那个转存的宏，删除后就不会运行那个了
至于另外问题，你是要保存那个，删除那个工作表不是很清楚

gcloveu

0126 发表于 2017-9-1 09:26
Call 另存为(g + 1)

不另存就把这个删掉吧，这个是调运行最后那个转存的宏，删除后就不会运行那个了

好的，明白了，谢谢你！