如何把一个Excel表拆分成多个文件，保留表头

chenjx80

路再见 发表于 2019-4-20 12:43
我还想问问，你去哪里学到这些？我买了本《别怕，Excel vba其实很简单》，看完还是不够。
还有，主文件 ...

F1 应该成为你最好的小伙伴！

如果嫌弃 Excel VBE 原有 F1 功能，则可以了解下：
在 Excel 2013+ 版本 VBE 中实现 F1 查询本地中文帮助
http://club.excelhome.net/thread-1443490-1-1.html

爱吃蜂蜜的狼

Sub test()
m = Dir(ThisWorkbook.Path & "\" & "*.xlsx")
If m = "" Then GoTo 90:
Kill ThisWorkbook.Path & "\" & m
Do
   m = Dir
   If m = "" Then Exit Do
   Kill ThisWorkbook.Path & "\" & m
Loop Until m = ""
90
Dim arr()
k = Sheet1.Range("a:a").Find("*", , , , , xlPrevious).Row
For Each Rng In Range("a3:a" & k)
    If Rng = "" Then
    n = n + 1
       ReDim Preserve arr(1 To n)
       arr(n) = Rng.Row
    End If
Next
With Workbooks("主文件.xlsm").Worksheets("1989-007")

For i = 1 To UBound(arr) + 1
If i = 1 Then
    Workbooks.Add.SaveAs ThisWorkbook.Path & "\" & .Range("b3") & i & ".xlsx"
    .Range("a1:d" & arr(i) - 1).Copy Workbooks(.Range("b3") & i & ".xlsx").Worksheets("sheet1").Range("a1")
    Workbooks(.Range("b3") & i & ".xlsx").Close savechanges:=True
    GoTo 100:
End If
If i > UBound(arr) Then
    Workbooks.Add.SaveAs ThisWorkbook.Path & "\" & .Range("b" & arr(i - 1) + 1) & i & ".xlsx"
    .Range("a1:d2").Copy Workbooks(.Range("b" & arr(i - 1) + 1) & i & ".xlsx").Worksheets("sheet1").Range("a1")
    .Range("a" & arr(i - 1) + 1 & ":d" & k).Copy Workbooks(.Range("b" & arr(i - 1) + 1) & i & ".xlsx").Worksheets("sheet1").Range("a3")
    Workbooks(.Range("b" & arr(i - 1) + 1) & i & ".xlsx").Close savechanges:=True
    Exit Sub
End If
    Workbooks.Add.SaveAs ThisWorkbook.Path & "\" & Sheet1.Range("b" & arr(i - 1) + 1) & i & ".xlsx"
    .Range("a1:d2").Copy Workbooks(.Range("b" & arr(i - 1) + 1) & i & ".xlsx").Worksheets("Sheet1").Range("a1")
    .Range("a" & arr(i - 1) + 1 & ":d" & arr(i) - 1).Copy Workbooks(.Range("b" & arr(i - 1) + 1) & i & ".xlsx").Worksheets("Sheet1").Range("a3")
   
   
    Workbooks(.Range("b" & arr(i - 1) + 1) & i & ".xlsx").Close savechanges:=True
100
Next
End With
End Sub

路再见

爱吃蜂蜜的狼 发表于 2019-4-20 16:32
Sub test()
m = Dir(ThisWorkbook.Path & "\" & "*.xlsx")
If m = "" Then GoTo 90:

厉害，请问你看什么教材，怎么学的？

爱吃蜂蜜的狼

路再见 发表于 2019-4-20 19:54
厉害，请问你看什么教材，怎么学的？

https://www.51zxw.net/这个网站上有整套的视频教程

闻启学

路再见 发表于 2019-4-20 12:43
我还想问问，你去哪里学到这些？我买了本《别怕，Excel vba其实很简单》，看完还是不够。
还有，主文件 ...

你是佛山的

yaozong

1. Sub 按B列字段拆分到新建工作簿()
   
2. Sheets("1989-007").Activate
   
3. Dim wb As Workbook, rng As Range, arr, ar, s$, i&
   
4. arr = Range("D1", [a65536].End(3)).Value
   
5. For i = 3 To UBound(arr)
   
6.   If InStr(arr(i, 2), "新闻串联单") > 0 Then
   
7.     Set rng = Range("A1:D2")
   
8.     s = Trim(arr(i, 2))
   
9.     ar = Range(Cells(i, 2), Cells(i, 2).End(4)).Value
   
10.     Set rng = Union(rng, Cells(i, 1).Resize(UBound(ar), 4))
    
11.     Set wb = Workbooks.Add
    
12.     With wb.Sheets(1)
    
13.        rng.Copy .Range("A1")
    
14.     End With
    
15.     wb.SaveAs Filename:=ThisWorkbook.Path & "" & s
    
16.     wb.Close
    
17.     i = i + UBound(ar) + 1
    
18.   End If
    
19. Next
    
20. End Sub

复制代码

mjzxlmg

想保留原表的格式可用复制工作表的方法，然后删除不要的行就好。

路再见

yaozong 发表于 2019-4-21 18:08

有改进空间，而且思路可取。