按单元格命名批量拆分表格及对应数据

aquariusxiao

各位老师，大致需求如下：

①需要根据Q列唯一值，批量拆分若干新的excel表格，新表格文件名就以Q列唯一值分别命名
②新生成的excel中的A-P列，需要根据原表格Q列数据（也就是新表的文件名），保留所有对应的数据
③新生成的excel中的Q列为空，或使用原表格Q列相应的数据但文字用白色显示
④新生成的excel中的R-T列为固定格式，完全使用原表格数据即可
按单元格命名批量拆分表格及对应数据.rar (931.1 KB, 下载次数: 8)

2024-8-16 18:31 上传

点击文件名下载附件

附件中的原表格是需要拆分的原表，其他三个表是我手工拆分后的结果，供老师们参考
目前几乎每天在通过手工复制删除数据来完成，一旦Q列的单号多就会很抓狂，还望各位老师能帮忙看下，感谢！

chxw68

练习。。。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

opel-wong

我也来凑个热闹，代码如下，供参考 ：

opel-wong

附件如下，


         原表格.zip (908.31 KB, 下载次数: 6)

2024-8-16 19:55 上传

点击文件名下载附件

Qs18

Sub qs()
Dim wb As Workbook, xb As Workbook, dic As Object, sht As Worksheet, rng As Range
Set wb = ThisWorkbook: Set dic = CreateObject("scripting.dictionary")
Set sht = wb.Sheets("电子送货单")
ph = ThisWorkbook.Path & "\"
arr = Sheet1.Range("q2:q" & Sheet1.Cells(Rows.Count, "q").End(3).Row)
For i = 1 To UBound(arr)
    If Not dic.exists(arr(i, 1)) Then
        If arr(i, 1) <> Empty Then
        dic(arr(i, 1)) = ""
        End If
    End If

Next
yyy = dic.keys
Application.ScreenUpdating = False: Application.DisplayAlerts = False
For Each k In dic.keys
    sht.Copy
    Set xb = ActiveWorkbook
    rw = xb.Sheets(1).Cells(Rows.Count, "q").End(3).Row
'    xb.Sheets(1).Range("A" & 10).Resize(1, 17).Select
    For i = rw To 2 Step -1
        If xb.Sheets(1).Range("q" & i).Value <> k Then
                xb.Sheets(1).Range("A" & i).Resize(1, 17).Delete Shift:=xlUp
        Else
                xb.Sheets(1).Range("q" & i).Value = ""
        End If
        
    Next
   
    xb.SaveAs ph & k & ".xlsx"
    xb.Close
Next
Application.ScreenUpdating = True: Application.DisplayAlerts = True
Set dic = Nothing: Set wb = Nothing: Set xb = Nothing
MsgBox "完成！"
End Sub

Qs18

试试........

Qs18

试试..........