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