vba拆分数据至不同目录不同工作簿

Option Explicit
Option Base 1

Sub TestGetProvinceCollection()
    Dim sht As Worksheet, provinceCol As Integer
    Set sht = ActiveSheet
    provinceCol = 13 '非直邮
    
    Dim c As Collection
    Set c = GetProvinceCollection(sht, provinceCol)
    
    Dim myDir As String
    myDir = GetDeskDir() + "\gh"
    CreateDir (myDir)
    
    Dim arr, filename As String
    Dim wb As Workbook, shtNew As Worksheet
    Dim p As Variant
    For Each p In c
        myDir = GetDeskDir() + "\gh\" & p
        CreateDir (myDir)
        filename = myDir & "\非直邮卡 " & p & ".xlsx"
        
        Set wb = Application.Workbooks.Add
        
        Set shtNew = ActiveWorkbook.Worksheets.Add()
        shtNew.Name = p
        arr = GetData(GetHHCollection(CStr(p), provinceCol, sht), sht)
        shtNew.Range(shtNew.Cells(1, 1), shtNew.Cells(UBound(arr, 1), UBound(arr, 2))) = arr
        
        wb.SaveAs filename:=filename
        wb.Close
        Set shtNew = Nothing
        Set wb = Nothing
        
        
    Next
   
End Sub


Function GetData(c As Collection, sht As Worksheet)
    Dim colCount As Integer, it
    Dim i As Long, j As Integer
    Dim allData
    allData = sht.UsedRange.Value2
    colCount = UBound(allData, 2)
    Dim obj()
    ReDim obj(c.Count + 1, colCount)

    ' first line
    For j = 1 To colCount Step 1
        obj(1, j) = allData(1, j)
    Next
    
    For i = 1 To c.Count Step 1
        For j = 1 To colCount Step 1
            obj(i + 1, j) = allData(c.Item(i), j)
        Next
    Next
    GetData = obj
End Function

Function GetHHCollection(province As String, provinceCol As Integer, sht As Worksheet)
    Dim i As Long
    Dim allData
    Dim c As New Collection
    Dim p As String
    allData = sht.UsedRange.Value2

    For i = 2 To UBound(allData, 1)
        If IsEmpty(allData(i, provinceCol)) Then
            p = "空白"
        Else
            p = allData(i, provinceCol)
        End If

        If p = province Then c.Add i
    Next

    Set GetHHCollection = c
End Function

Function HasContent(c As Collection, v As String) As Boolean
    Dim s As Variant
    Dim result As Boolean
    result = False
    For Each s In c
        If CStr(s) = CStr(v) Then
            result = True
            Exit For
        End If
    Next
    HasContent = result
End Function

Function GetProvinceCollection(sht As Worksheet, provinceCol As Integer) As Collection
    Dim i As Long
    Dim allData
    Dim provinceCollection As New Collection, province As String
       
    allData = sht.UsedRange.Value2
       
    For i = 2 To UBound(allData, 1)
        If IsEmpty(allData(i, provinceCol)) Then
            province = "空白"
        Else
            province = allData(i, provinceCol)
        End If
    
        If Not HasContent(provinceCollection, province) Then provinceCollection.Add province
    Next
    
    Set GetProvinceCollection = provinceCollection
End Function


Function GetDeskDir()
    GetDeskDir = CreateObject("WScript.Shell").SpecialFolders("Desktop")
End Function


Sub CreateDir(str As String)
  Dim sr
  sr = Dir(str, vbDirectory)
  If sr = "" Then
    'MsgBox "不存在此目录:" & str
    MkDir str
  Else
    'MsgBox str & "存在"
  End If
End Sub