拆分到每户户主一个工作簿每个表都要有表头与表尾

yay183

每个工作簿可以不要户号吗？因为打印出来不需要。自己研究不到。

Sub 按A列区分内容并拆分到工作薄()
Dim i%
arr = Sheets(1).[a1].CurrentRegion
Set d = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
   If d.exists(arr(i, 7)) Then
    Set d(arr(i, 1)) = Union(d(arr(i, 1)), Rows(i))
   Else
    Set d(arr(i, 1)) = Union(Rows(“1:6”), Rows(i))
   End If
Next i

For ss = 0 To d.Count - 1
    Workbooks.Add
    With ActiveWorkbook
        d.items()(ss).Copy .Sheets(1).[a1]
        .SaveAs ThisWorkbook.Path & "/" & d.keys()(ss)
        .Close
    End With
Next ss
MsgBox "快学Excel提示您，工作薄拆分完毕！"
End Sub
教程抄的，自己修改了表头，这个代码不会参考A例拆分，只会按表头6例拆。搞不明白，求助。

3190496160

原贴中很多人给出了解决方案，还有什么问题在原贴中追问，新开一贴，从头问起？？

yay183

3190496160 发表于 2021-4-24 11:21
原贴中很多人给出了解决方案，还有什么问题在原贴中追问，新开一贴，从头问起？？

想要分一户一个工作簿，自己不会修改。

sirsunny

1. Sub 将一个工作簿拆分成多个工作簿()
   
2.     Dim arr, rng As Range, Sht As Worksheet, dic As Object
   
3.     Dim k, t, i As Long, lc As Long, str As String
   
4.     Application.ScreenUpdating = False
   
5.     arr = Range("a1").CurrentRegion.Value
   
6.     lc = UBound(arr, 2)
   
7.     Set rng = Rows("1:6")
   
8.     Set dic = CreateObject("scripting.dictionary")
   
9.     For i = 7 To UBound(arr) - 5
   
10.         str = arr(i, 1)
    
11.         If Not dic.exists(str) Then
    
12.             Set dic(str) = Cells(i, 1).Resize(, lc)
    
13.         Else
    
14.             Set dic(str) = Union(dic(str), Cells(i, 1).Resize(, lc))
    
15.         End If
    
16.     Next
    
17.    
    
18.     k = dic.keys
    
19.     t = dic.items
    
20.     For i = 0 To dic.Count - 1
    
21.         With Workbooks.Add
    
22.             With .Sheets(1).[a1]
    
23.                 ThisWorkbook.Sheets("数据").Rows("1:6").Copy
    
24.                 .PasteSpecial Paste:=xlPasteAll, Operation:=xlNone
    
25.                 t(i).Copy .Offset(6, 0)
    
26.             End With
    
27.             .SaveAs ThisWorkbook.Path & "" & k(i), xlWorkbookDefault '保存工作簿
    
28.             .Close True
    
29.         End With
    
30.     Next
    
31. End Sub

复制代码

yay183

sirsunny 发表于 2021-4-24 14:04

谢谢你，可以拆分了，但是无表尾。

3190496160

Sub chaife()
Dim d As Object
Dim rng As Range
Set d = CreateObject("scripting.dictionary")
Set sh = ThisWorkbook.Worksheets("数据")
ar = sh.UsedRange
For i = 7 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        If IsNumeric(Left(Trim(ar(i, 1)), 1)) Then
            d(Trim(ar(i, 1))) = ""
        End If
    End If
Next i
For Each k In d.keys
    sh.Copy
    Set wb = ActiveWorkbook
    With wb.Worksheets(1)
        .Name = k
        For i = 7 To UBound(ar)
            If IsNumeric(Left(Trim(.Cells(i, 1)), 1)) Then
                If Trim(.Cells(i, 1)) <> k Then
                    If rng Is Nothing Then
                        Set rng = .Rows(i)
                    Else
                        Set rng = Union(rng, .Rows(i))
                    End If
                End If
            End If
        Next i
        If Not rng Is Nothing Then rng.Delete
        .Columns("A:A").EntireColumn.Hidden = True
    End With
    Set rng = Nothing
    wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k & ".xlsx"
    wb.Close False
Next k
MsgBox "ok!"
End Sub

3190496160

拆分到每户户主一个工作簿每个表都要有表头与表尾.zip (21.24 KB, 下载次数: 92)

2021-4-24 17:43 上传

点击文件名下载附件

yay183

3190496160 发表于 2021-4-24 17:43

实在太感谢你了。

娱乐部长

直接按户主名生成工作薄。
import xlwings as xw
app=xw.App(visible=False,add_book=False)
wb=xw.Book('D:\\360安全浏览器下载\\求助表\\求助表.xlsx')
ws=wb.sheets[1]
sht=wb.sheets[0]
d={}
data=ws.range(ws.used_range).value
for row in data[6:]:
    if row[0] not in d:
        d[row[0]]=[row[2:]]
    else:
        d[row[0]]+=[row[2:]]
for x,y in d.items():
    hz=y[0][0]
    sht.range('c3').value=y[0][0]
    sht.range('b7').options(expane='table').value=y
    r=7
    for n in range(len(y)):
        sht.range(r,1).value=n+1
        r+=1
    wb.save('D:\\360安全浏览器下载\\求助表\\'+hz+'.xlsx')
    sht.range('a7:m21').value=''
app.quit()

sirsunny

娱乐部长 发表于 2021-4-24 21:45
直接按户主名生成工作薄。
import xlwings as xw
app=xw.App(visible=False,add_book=False)

Python厉害