拆分工作表

沈默00

加了一句，，已测试换成真实的身份证号码可以正常使用

沈默00

jstsht 发表于 2024-4-22 15:44
如果不用VBA，最好的方法是用方方格子

这个可以呀，我也一直在用方方格子，只是现在用的少了

沈默00

jstsht 发表于 2024-4-22 16:12
你没发现身份证号变成科学计数法了？

加了一句设置成文本的代码，用真实身份证号码，不会变了，

沈默00

3190496160 发表于 2024-4-22 14:52
.UsedRange.Offset(2).Clear
这句似乎应该改进一下，把格式都删除了，拷贝总表就没有任何意义了，身份证 ...

是的，后面要加一句设置格式的，清除是为了把线框给清理了

沈默00

3190496160 发表于 2024-4-22 17:41
.UsedRange.Offset(2).Borders.LineStyle =0
UsedRange.Offset(2)=empty

是的，就是需要多写一句，，，

ykcbf1100

借题练习，总表拆分为多表，VBA

ykcbf1100

1. Sub ykcbf()   '//2025.7.21 总表原格式拆分成多工作表
   
2.     Dim d As Object, ws As Workbook, sh As Worksheet, sht As Worksheet
   
3.     Dim arr As Variant, r As Long, c As Long, bt As Long, col As Long, i As Long
   
4.     Dim s As String, k As Variant, rng As Range, tm As Double
   
5.     Dim shtName As String
   
6.     tm = Timer
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     Set ws = ThisWorkbook
   
9.     Application.ScreenUpdating = False
   
10.     Application.DisplayAlerts = False
    
11.     Application.Calculation = xlCalculationManual
    
12.     On Error Resume Next
    
13.     Set sh = ws.ActiveSheet
    
14.     If sh Is Nothing Then
    
15.         MsgBox "未找到【Sheet1】工作表！", vbCritical
    
16.         GoTo CleanExit
    
17.     End If
    
18.     On Error GoTo 0
    
19.     bt = 2: col = 11
    
20.     With sh
    
21.         r = .Cells(.Rows.Count, col).End(xlUp).Row
    
22.         c = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    
23.         arr = .Range(.Cells(1, 1), .Cells(r, c)).Value2
    
24.     End With
    
25.     For i = bt + 1 To UBound(arr)
    
26.         If Not IsEmpty(arr(i, col)) Then
    
27.             s = Trim(CStr(arr(i, col)))
    
28.             If Len(s) > 0 Then d(s) = 1
    
29.         End If
    
30.     Next
    
31.     Application.DisplayAlerts = False
    
32.     For Each sht In ws.Sheets
    
33.         If sht.Name <> sh.Name Then sht.Delete
    
34.     Next
    
35.     Application.DisplayAlerts = True
    
36.     For Each k In d.keys
    
37.         sh.Copy After:=ws.Sheets(ws.Sheets.Count)
    
38.         Set sht = ws.Sheets(ws.Sheets.Count)
    
39.         sht.Name = Left(Replace(k, "/", "_"), 31)  ' 确保名称合法
    
40.         With sht
    
41.             On Error Resume Next
    
42.             .DrawingObjects.Delete
    
43.             .AutoFilterMode = False
    
44.             .Range("A1").Resize(r, c).AutoFilter col, "<>" & k
    
45.             Set rng = .AutoFilter.Range.Offset(bt).Resize(r - bt).SpecialCells(xlCellTypeVisible)
    
46.             If Not rng Is Nothing Then rng.EntireRow.Delete
    
47.             .AutoFilterMode = False
    
48.             On Error GoTo 0
    
49.         End With
    
50.     Next
    
51.     sh.Activate
    
52. CleanExit:
    
53.     Application.ScreenUpdating = True
    
54.     Application.DisplayAlerts = True
    
55.     Application.Calculation = xlCalculationAutomatic
    
56.     MsgBox "■ 拆分操作完成 ■" & vbCrLf & _
    
57.         "═══════════════════════" & vbCrLf & _
    
58.         "■ 处理时间: " & Format(Timer - tm, "0.000") & "秒" & vbCrLf & _
    
59.         "■ 处理行数: " & UBound(arr) - bt & "行" & vbCrLf & _
    
60.         "■ 生成表数: " & d.Count & "个" & vbCrLf & _
    
61.         "═══════════════════════", _
    
62.         vbInformation, "执行报告"
    
63.     Set d = Nothing
    
64. End Sub
    
65. 
    
66. 
    

复制代码