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

jaxxcyh · 发表于 2024-8-13 13:52

Sub test()
Application.ScreenUpdating = False
'统计数据行数，列数
Dim myRow As Long, myCol As Long
myRow = Sheet1.[a4].End(xlDown).Row
myCol = 11

'建字典，存子公司名称
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
For i = 4 To myRow
      d(Sheet1.Cells(i, 1).Value) = d(Sheet1.Cells(i, 1).Value) + 1  '统计每个子公司的记录数
Next

'清理旧表
Application.DisplayAlerts = False
Dim mySht As Worksheet
For Each mySht In Sheets
      If mySht.Name <> "Sheet1" Then mySht.Delete
Next
Application.DisplayAlerts = True

'复制记录到每张子表
Dim item
For Each item In d                                     '每个子公司逐个上场
      Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)    '先拷贝总表
      Set mySht = Sheets(Sheets.Count)
      mySht.Name = item                                  '改个名就是俺的表
      mySht.Activate                                     '进自家地盘
      For j = myRow To 4 Step -1                         '逐个甄别，开始大清洗
         If Cells(j, 1).Value <> item Then Rows(j).Delete  '不是俺公司的就滚蛋
      Next
Next
Sheet1.Activate
Application.ScreenUpdating = True
MsgBox "OK"
End Sub

limonet · 发表于 2024-8-13 13:57

jaxxcyh 发表于 2024-8-13 13:24
数据库这玩意太高级，看不懂

你是要看懂，还是要解决问题？

小jy · 发表于 2024-8-13 14:40

刚开始学，结合老师的代码修改的，但是没有合计行

悠扬的旋律 · 发表于 2024-8-14 20:17

ykcbf1100 发表于 2024-8-13 09:38
参与一下。。。

学习一下

Sub ykcbf()'筛选删除行
Dim 编号02_字典
Dim 编号04_工作表
Dim 编号05_文件夹路径
Dim 编号06_标题行数
Dim 编号07_按第几列拆分
Dim 编号08_列数
Dim 编号09_合计在第几行
Dim 编号10_数组
Dim 编号11_第几行
Dim 编号12_字符串
Dim 编号13_key
Set 编号02_字典 = CreateObject("scripting.dictionary")
Set 编号04_工作表 = ThisWorkbook.Sheets("Sheet1")
编号05_文件夹路径 = ThisWorkbook.Path & ""
编号06_标题行数 = 3
编号07_按第几列拆分 = 1
编号08_列数 = 编号04_工作表.UsedRange.Columns.Count
编号09_合计在第几行 = 编号04_工作表.UsedRange.Find("合计").Row
编号10_数组 = 编号04_工作表.[a1].Resize(编号09_合计在第几行, 编号08_列数)
For 编号11_第几行 = 编号06_标题行数 + 1 To UBound(编号10_数组, 1)
变量 = 编号10_数组(编号11_第几行, 编号07_按第几列拆分)
编号12_字符串 = Trim(变量)
If 编号12_字符串 <> "" Then
编号02_字典(编号12_字符串) = ""
End If
Next
For Each 编号13_key In 编号02_字典.keys
编号04_工作表.Copy
ActiveWorkbook.Sheets(1).AutoFilterMode = 0
ActiveWorkbook.Sheets(1).DrawingObjects.Delete
ActiveWorkbook.Sheets(1).Rows(编号06_标题行数 & ":" & 编号06_标题行数).AutoFilter
ActiveWorkbook.Sheets(1).Cells(编号06_标题行数, 1).AutoFilter Field:=编号07_按第几列拆分, Criteria1:="<>" & 编号13_key
ActiveWorkbook.Sheets(1).Cells(编号06_标题行数 + 1, 1).Resize(编号09_合计在第几行).EntireRow.Delete
ActiveWorkbook.Sheets(1).AutoFilterMode = 0
ActiveWorkbook.SaveAs 编号05_文件夹路径 & 编号13_key
ActiveWorkbook.Close
Next
End Sub

复制代码

悠扬的旋律 · 发表于 2024-8-15 10:09

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

学习一下

Sub limonet()'sql
Dim 编号01_Connection
Dim 编号02_字符串
Dim 编号03_数组200
Dim 编号04_第几列
Dim 编号05_Sql
Dim 编号06_文件路径
Dim 编号07_文件路径
Dim 编号08_Recordset
Dim 编号09_Sql
Dim 编号10_字符串
Set 编号01_Connection = CreateObject("Adodb.Connection")
编号02_字符串 = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0 xml;HDR=NO';Data Source="
编号06_文件路径 = ThisWorkbook.FullName
编号01_Connection.Open 编号02_字符串 & 编号06_文件路径
编号09_Sql = "Select Distinct F1 From [Sheet1$A4:K] Where F1<>''"
Set 编号08_Recordset = 编号01_Connection.Execute(编号09_Sql)
编号03_数组200 = 编号08_Recordset.GetRows
编号01_Connection.Close
For 编号04_第几列 = 0 + 1 To UBound(编号03_数组200, 2) + 1
编号10_字符串 = 编号03_数组200(0, 编号04_第几列 - 1)
编号07_文件路径 = ThisWorkbook.PATH & "" & 编号10_字符串 & ".xlsx"
编号01_Connection.Open 编号02_字符串 & 编号07_文件路径
编号05_Sql = "Select * Into 工作表名称 From [Excel 12.0;HDR=NO;Database=" & ThisWorkbook.FullName & "].[Sheet1$A4:K] Where F1='" & 编号10_字符串 & "'"
Set 编号08_Recordset = 编号01_Connection.Execute(编号05_Sql)
编号01_Connection.Close
Next
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[求助] 根据A列公司名称拆分工作簿