筛选条件数据,另保存为工作簿(自己做的第一个小VBA,很高兴,请大家指正)
我需要按照A列地区名称,将数据分别抓出,另外保存新工作簿,工作簿名称就用地区名称。
程序如下,第一次编VBA,不知能否优化或有其他方法?请指正,谢谢:
Sub 分地区()
Dim m As Integer, n As Integer, t As Integer, ran As Range, name As String
m = 3
t = Range('a65536').End(xlUp).EntireRow.Row
Do Until m >= t
For n = m To t
If Range('a'& (n))< > Range('a'& (n - 1)) Then '判断当前行
Set ran = Range('a1:a2') '重置
Set ran = Union(ran, Range('a'& n)) '加入当前单元格
End If
If Range('a'& (n + 1)) = Range('a'& n) Then '判断下一行
Set ran = Union(ran, Cells(n + 1, 1)) '符合条件单元格加入
Else
name = Range('a'& n).Text '提取文件名
Workbooks.Add '新建工作簿
ran.EntireRow.Copy Sheets('sheet1').Range('a1') '拷贝数据
Application.DisplayAlerts = False '系统提示选择默认
ActiveWorkbook.SaveAs ThisWorkbook.Path& '/'& name& '.xls', FileFormat _
:=xlExcel8 '保存到当前文件夹,存为97-2003格式
Application.DisplayAlerts = True '系统提示改回
ActiveWorkbook.Close '关闭文件
m = n + 1 '下一区域
Exit For
End If
Next
Loop
End Sub