按单位拆分的延伸问题

87031226

如何将单位和单位汇总拆分在同一个工作簿里。。。。。。

limonet

关键字：distinct+like

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, i%, Sht As Worksheet
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    Arr = Cn.Execute("Select Distinct 省份 From [示例$A:J] Where 地市<>''").GetRows
    For i = 0 To UBound(Arr, 2)
        Worksheets.Add(After:=Worksheets(Sheets.Count)).Name = Arr(0, i)
        Worksheets("示例").Range("A1:J1").Copy Range("A1")
        StrSQL = "Select * From [示例$A:J] Where 省份 Like '" & Arr(0, i) & "'+'%'"
        Range("A2").CopyFromRecordset Cn.Execute(StrSQL)
    Next i
End Sub

半百

LIUZHU

JSA代码

1. function 拆分(){
   
2.         let arr=Sheets.Item("示例").Range("a1").CurrentRegion.Value2;
   
3.         let obj=arr.slice(3).reduce((dic,x)=>{
   
4.                 let dw=x[2].replace("汇总","");
   
5.                 return ((dic[dw]=dic[dw] || []).push(x),dic);
   
6.         },{});
   
7.         for (let key in obj){
   
8.                 try{Sheets.Item(key).Delete()}catch{};
   
9.                 Sheets.Item("示例").Copy(null,Sheets.Item(Sheets.Count));
   
10.                 ActiveSheet.Name=key;
    
11.                 Range(`4:${ActiveSheet.UsedRange.Count}`).Delete();
    
12.                 let temp=obj[key];
    
13.                 Range("a4").Resize(temp.length,temp[0].length).Value2=temp;
    
14.         }
    
15. }

复制代码

LIUZHU

附件请用WPS测试

ykcbf1100

附件供参考。。。

2级字典

ykcbf1100

参与一下。。。

1. Sub ykcbf2()   '//2024.4.1
   
2.     Dim wb, arr, sh
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set d = CreateObject("Scripting.Dictionary")
   
7.     Set sh = ThisWorkbook.Sheets("示例")
   
8.     arr = sh.UsedRange
   
9.     bt = 3        '//标题行数
   
10.     col = 3       '//拆分列号
    
11.     For i = bt + 1 To UBound(arr)
    
12.         s = arr(i, col)
    
13.         If InStr(s, "汇总") = 0 And s <> Empty Then
    
14.             If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
15.             d(s)(i) = i
    
16.         End If
    
17.     Next
    
18.     On Error Resume Next
    
19.     For Each k In d.keys
    
20.         sh.Copy
    
21.         Set wb = ActiveWorkbook
    
22.         m = 0
    
23.         ReDim brr(1 To d(k).Count + 1, 1 To UBound(arr, 2))
    
24.         With wb.Sheets(1)
    
25.             .Name = k
    
26.             .DrawingObjects.Delete
    
27.             .UsedRange.Offset(bt + d(k).Count + 1).Clear
    
28.             For i = 4 To UBound(arr)
    
29.                 If InStr(arr(i, 3), k) Then
    
30.                     m = m + 1
    
31.                     For j = 1 To UBound(arr, 2)
    
32.                         brr(m, j) = arr(i, j)
    
33.                     Next
    
34.                 End If
    
35.             Next
    
36.             .Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = brr
    
37.         End With
    
38.         wb.SaveAs p & k
    
39.         wb.Close 1
    
40.     Next
    
41.     Application.ScreenUpdating = True
    
42.     MsgBox "OK！"
    
43. End Sub
    

复制代码

87031226

ykcbf1100 发表于 2024-4-1 12:21
附件供参考。。。

2级字典

厉害厉害。。。。。。。。。