使用VBA根据关键词拆分工作表

MielOne

求教各位大师，如何根据工作表中的关键词自动拆分出到关键词为止之上的内容为一个新的Excel文件，并以关键词命名。
然后继续检索到下一个关键词，再拆分出这个关键词到第一个关键词的内容为一个新的Excel文件，并以第二个关键词命名。
可能描述的不是很清楚，上个附件，仓库AH是固定要检索的关键词，最后需要的效果就是拆出3个文件，分别以仓库AH1948、仓库AH1856、仓库AH1999命名
感谢各位
拆分.rar (6.26 KB, 下载次数: 40)

2014-7-23 21:14 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim wb As Workbook
   
5.   Dim ws As Worksheet
   
6.   Dim mypath$, myname$
   
7.   Application.ScreenUpdating = False
   
8.   Application.DisplayAlerts = False
   
9.   Application.SheetsInNewWorkbook = 1
   
10.   mypath = ThisWorkbook.Path & ""
    
11.   With Worksheets("sheet1")
    
12.     r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
13.     i0 = 1
    
14.     For i = 1 To r
    
15.       If Left(.Cells(i, 2), 4) = "仓库AH" Then
    
16.         wjm = .Cells(i, 2)
    
17.         c = .Rows(i0 & ":" & i).Find(what:="*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
    
18.         arr = .Range(.Cells(i0, 1), .Cells(i, c))
    
19.         Set wb = Workbooks.Add
    
20.         With wb
    
21.           With .Worksheets("sheet1")
    
22.             .Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
23.           End With
    
24.           .SaveAs Filename:=mypath & wjm & ".xls"
    
25.           .Close
    
26.         End With
    
27.         i0 = i + 1
    
28.       End If
    
29.     Next
    
30.   End With
    
31. End Sub
    

复制代码

chxw68

参见附件。

MielOne

chxw68 发表于 2014-7-23 22:29
参见附件。

非常感谢，经测试完美解决了我的需求

MielOne

chxw68 发表于 2014-7-23 22:29
参见附件。

再来请教一下，如果希望是检索到第一个关键词，拆分出从这个词到第二个关键词之间的内容应该如何改这段代码呢？也就是说要变成保留关键词及其之下的内容（之前是之上内容），万分感谢。

MielOne

新加附件，谢谢
仓库管理表格拆分1.rar (11.7 KB, 下载次数: 8)

2014-7-24 19:23 上传

点击文件名下载附件

chxw68

1. Sub test2()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim wb As Workbook
   
5.   Dim ws As Worksheet
   
6.   Dim mypath$, myname$
   
7.   Application.ScreenUpdating = False
   
8.   Application.DisplayAlerts = False
   
9.   Application.SheetsInNewWorkbook = 1
   
10.   mypath = ThisWorkbook.Path & ""
    
11.   With Worksheets("sheet1")
    
12.     r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
13.     i1 = r
    
14.     For i = r To 1 Step -1
    
15.       If Left(.Cells(i, 2), 4) = "仓库AH" Then
    
16.         wjm = .Cells(i, 2)
    
17.         c = .Rows(i & ":" & i1).Find(what:="*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
    
18.         arr = .Range(.Cells(i, 1), .Cells(i1, c))
    
19.         Set wb = Workbooks.Add
    
20.         With wb
    
21.           With .Worksheets("sheet1")
    
22.             .Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
23.           End With
    
24.           .SaveAs Filename:=mypath & wjm & ".xls"
    
25.           .Close
    
26.         End With
    
27.         i1 = i - 1
    
28.       End If
    
29.     Next
    
30.   End With
    
31. End Sub

复制代码

chxw68

详见附件。

有杕之杜

简直太棒了，感谢chxw68老师。