根据总表的内容遇到空格，拆分完整的表格明细到分表

vicky427000

现金日记账.rar (27.16 KB, 下载次数: 15)

2024-3-20 16:36 上传

点击文件名下载附件
123

总表是一个现金日记账，但是公司每个商店都有一个现金日记账，然后系统导出的数据就是日记账都在一起，用空格隔开，我现在要把日记账下发，所以要把日记账拆分出来，根据每个日记账表头拆分到不同的工作表，大家帮忙看看要怎么拆分

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub 拆分()  '//2024.3.20
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set sh = Sheets("总表")
   
6.     r = Cells(Rows.Count, 1).End(3).Row
   
7.     p = ThisWorkbook.Path & ""
   
8.     arr = Range("A1:I" & r)
   
9.     u = UBound(arr, 2)
   
10.     On Error Resume Next
    
11.     For Each sht In Sheets
    
12.         If sht.Name <> sh.Name Then sht.Delete
    
13.     Next
    
14.     For i = 1 To r
    
15.         If InStr(arr(i, 1), "库存现金-现金先令") Then k = k + 1: d(k) = i
    
16.     Next
    
17.     For k = 1 To d.Count
    
18.         r1 = d(k)
    
19.         If k = d.Count Then r2 = r Else r2 = d(k + 1) - 1
    
20.         fn = arr(r1, 1)
    
21.         Set sht = Sheets.Add(After:=Sheets(Sheets.Count))
    
22.         sht.Name = fn
    
23.         Set Rng = sh.Range(sh.Cells(r1, 1), sh.Cells(r2, u))
    
24.         Rng.Copy
    
25.         sht.Select
    
26.         [a1].PasteSpecial Paste:=xlPasteColumnWidths
    
27.         ActiveSheet.Paste
    
28.         ActiveSheet.[a1].Select
    
29.         Application.CutCopyMode = False
    
30.         sht.DrawingObjects.Delete
    
31.     Next
    
32.     sh.Activate
    
33.     Application.ScreenUpdating = True
    
34.     MsgBox "OK！"
    
35. End Sub
    

复制代码

dy83797465268

用的时候将总表以外的工作表全部删除

limonet

关键字：distinct

limonet

Sub limonet()
    Dim Cn As Object, Arr As Variant, i%
    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 [总表$A3:I] Where 科目编码<>'' And Not 科目名称 Like '科目'+'%'").GetRows
    For i = 0 To UBound(Arr, 2)
        Worksheets.Add(after:=Worksheets(Sheets.Count)).Name = Arr(0, i)
        Range("A1").Resize(1, 8) = Split("日期￥凭证字号￥科目编码￥科目名称￥借方￥贷方￥方向￥余额", "￥")
        Range("A2").CopyFromRecordset Cn.Execute("Select * From [总表$A3:I] Where 科目名称='" & Arr(0, i) & "'")
    Next i
End Sub

NBCBA123

1. Sub test()
   
2. Dim brr()
   
3. Application.ScreenUpdating = False
   
4. Application.DisplayAlerts = False
   
5. For Each sht In Sheets
   
6.     If sht.Name <> "总表" Then sht.Delete
   
7. Next sht
   
8. last_row = Cells(Rows.Count, 1).End(xlUp).Row
   
9. last_column = Cells(last_row, 1).End(xlToRight).Column
   
10. arr = Range([a1], Cells(last_row, last_column))
    
11. For row1 = 1 To UBound(arr)
    
12.     If InStr(Cells(row1, 1).Value, "库存现金-现金先令") Then
    
13.         k = k + 1
    
14.         ReDim Preserve brr(1 To 3, 1 To k)
    
15.         brr(1, k) = Cells(row1, 1).Value
    
16.         brr(2, k) = "A" & row1
    
17.     ElseIf InStr(Cells(row1, 5).Value, "本年累计") Then
    
18.         brr(3, k) = "I" & row1
    
19.     End If
    
20. Next row1
    
21. For c = 1 To UBound(brr, 2)
    
22.     Sheets.Add(after:=Sheets(Sheets.Count)).Name = brr(1, c)
    
23.     Sheets("总表").Range(brr(2, c), brr(3, c)).Copy Sheets(brr(1, c)).Range("a1")
    
24.     Columns.AutoFit
    
25. Next c
    
26. Application.DisplayAlerts = True
    
27. Application.ScreenUpdating = True
    
28. End Sub

复制代码

vicky427000

谢谢大家，我最近的工作因为有大家的帮忙，顺利了很多，非常感谢，代码我回去好好学习下

saghj

交个作业

dy83797465268

vicky427000 发表于 2024-3-21 02:14
谢谢大家，我最近的工作因为有大家的帮忙，顺利了很多，非常感谢，代码我回去好好学习下

很多高手的~~每个人的解决方案都不一样，值得学习的~