根据A列公司名称拆分工作簿

rookie2021

求大神给一个代码可以把这张工作表按A列的公司名称，拆分成多个用公司名称命名的工作簿，工作簿里只包含这家公司的资产

少少飞翔

直接用易用宝吧，代码还挺麻烦的

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.13  总表按客户拆分
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim t: t = Timer
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set ws = ThisWorkbook
   
7.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
8.     p = ThisWorkbook.Path & ""
   
9.     bt = 3
   
10.     col = 1
    
11.     On Error Resume Next
    
12.     With sh
    
13.         c = .UsedRange.Columns.Count
    
14.         r = .UsedRange.Find("合计").Row
    
15.         arr = .[a1].Resize(r, c)
    
16.         For i = bt + 1 To UBound(arr)
    
17.             s = Trim(arr(i, col))
    
18.             If s <> Empty Then
    
19.                 d(s) = ""
    
20.             End If
    
21.         Next i
    
22.     End With
    
23.     For Each k In d.keys
    
24.         sh.Copy
    
25.         Set wb = ActiveWorkbook
    
26.         With wb.Sheets(1)
    
27.             .AutoFilterMode = False
    
28.             .DrawingObjects.Delete
    
29.             .Rows(bt & ":" & bt).AutoFilter
    
30.             .Cells(bt, 1).AutoFilter Field:=col, Criteria1:="<>" & k
    
31.             .Cells(bt + 1, 1).Resize(r).EntireRow.Delete
    
32.             .AutoFilterMode = False
    
33.         End With
    
34.         wb.SaveAs p & k
    
35.         wb.Close
    
36.     Next
    
37.     Application.ScreenUpdating = True
    
38.     Application.DisplayAlerts = True
    
39.     MsgBox "拆分完毕，共用时： " & Format(Timer - t, "0.000秒"), , "提示"
    
40. End Sub
    

复制代码

limonet

关键字：select into

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, i%, CS$
    Set Cn = CreateObject("Adodb.Connection")
    CS = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0 xml;HDR=NO';Data Source="
    Cn.Open CS & ThisWorkbook.FullName
    Arr = Cn.Execute("Select Distinct F1 From [Sheet1$A4:K] Where F1<>''").GetRows
    For i = 0 To UBound(Arr, 2)
        Cn.Close: Cn.Open CS & ThisWorkbook.Path & "\" & Arr(0, i) & ".xlsx"
        StrSQL = "Select * Into Sheet1 From [Excel 12.0;HDR=NO;Database=" _
                & ThisWorkbook.FullName & "].[Sheet1$A4:K] Where F1='" & Arr(0, i) & "'"
        Cn.Execute (StrSQL)
    Next i
End Sub

3190496160

Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set sh = ThisWorkbook.Worksheets("sheet1")
With sh
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 4 Then MsgBox "数据源为空！": End
    ar = .Range("a1:k" & r)
End With
For i = 4 To UBound(ar)
    If ar(i, 1) <> "" Then
        If Not d.exists(ar(i, 1)) Then Set d(ar(i, 1)) = CreateObject("scripting.dictionary")
        d(ar(i, 1))(i) = ""
    End If
Next i
For Each k In d.keys
    sh.Copy
    Set wb = ActiveWorkbook
    n = 0
    ReDim br(1 To d(k).Count, 1 To UBound(ar, 2))
    For Each kk In d(k).keys
        n = n + 1
        For j = 1 To UBound(ar, 2)
            br(n, j) = ar(kk, j)
        Next j
    Next kk
    With wb.Worksheets(1)
        .Name = k
        .UsedRange.Offset(3).Borders.LineStyle = 0
        .UsedRange.Offset(3) = Empty
        .[a4].Resize(n, UBound(br, 2)) = br
        .[a4].Resize(n, UBound(br, 2)).Borders.LineStyle = 1
    End With
    wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k & ".xlsx"
    wb.Close
Next k
Application.ScreenUpdating = True
MsgBox "ok!", 64, "提醒！"
End Sub

3190496160

拆分工作簿.rar (50.39 KB, 下载次数: 11)

2024-8-13 09:45 上传

点击文件名下载附件

jaxxcyh

1. 11楼有新的，这个编的不好，去掉了

复制代码

jaxxcyh

limonet 发表于 2024-8-13 09:39
Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, i%, CS$
    Set Cn = CreateObject("Ad ...

数据库这玩意太高级，看不懂