筛选条件数据，另保存为工作簿（自己做的第一个小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