主要用于地市收集地震应急资料用的
呵呵
把一个总的文件展开为按区县名分类的小EXCEL表
Dim id As String
Dim name As String
Dim filename As String
Dim path As String
Sub break()
filename = ThisWorkbook.name
path = ThisWorkbook.path
' path = Left(ThisWorkbook.fullname, InStrRev(ThisWorkbook.fullname, "\"))
ChDir path
MsgBox "即将展开各区县辖区情况，请耐心等待~~", vbInformation, filename
Dim sheet As Integer
Dim row As Integer
row = 2
Sheets("区县").Select
Do Until Range("A" & row) = ""
Sheets("区县").Select
id = Left(Range("A" & row), 6)
name = Range("B" & row)
If Not name = "" Then
Workbooks.Add
ActiveWorkbook.SaveAs filename:=name & ".xls", FileFormat:= _
xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Windows(name & ".xls").Activate
For sheet = 1 To 3
If sheet = 1 Then
Sheets("Sheet1").name = "区县"
sub_copy ("区县")
ElseIf sheet = 2 Then
Sheets("Sheet2").name = "乡镇"
sub_copy ("乡镇")
ElseIf sheet = 3 Then
Sheets("Sheet3").name = "自然村"
sub_copy ("自然村")
End If
Next
sub_copy2
ActiveWorkbook.Save
ActiveWindow.Close
End If
row = row + 1
Loop
MsgBox "完成!所在目录:" & path, vbInformation, filename
End Sub
Function sub_copy(level As String)
Dim row1 As Integer
Dim row2 As Integer
' id = "370783"
' name = "寿光市"
row1 = 1
row2 = 1
Windows(filename).Activate
Sheets(level).Select
Do
row1 = row1 + 1
If row1 = 32767 Then
Windows(name & ".xls").Activate
Exit Function
End If
Loop Until Left(Range("A" & row1), 6) = id
row2 = row1
Do While Left(Range("A" & row2), 6) = id
row2 = row2 + 1
Loop
Range("A" & row1 & ":C" & row2 - 1).Select
Selection.Copy
Windows(name & ".xls").Activate
Sheets(level).Select
Range("A2").Select
ActiveSheet.Paste
Range("A1") = "ID"
Range("B1") = "NAME"
If Not level = "自然村" Then
Range("C1") = "辖区情况"
End If
Columns("A:A").Select
Selection.NumberFormatLocal = "@"
If Not level = "区县" Then
Cells.Replace What:=name, Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End If
End Function
Function sub_copy2()
Dim row As Integer
Dim sheet As Integer
Dim row1 As Integer
Dim row2 As Integer
Dim flag As Boolean
row = 2
row1 = 2
row2 = 2
sheet = 4
flag = False
Sheets("乡镇").Select
Do Until Range("B" & row) = ""
id = Left(Range("A" & row), 9)
name = Range("B" & row).Value
' MsgBox id & name
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Sheet" & sheet).name = name
Sheets("自然村").Select
Do While Left(Range("A" & row2), 9) = id
row2 = row2 + 1
flag = True
Loop
' MsgBox row1 & "-" & row2
If flag Then
Range("A" & row1 & ":B" & row2 - 1).Select
Selection.Copy
Sheets(name).Select
Range("A2").Select
ActiveSheet.Paste
Else
Sheets(name).Select
End If
Columns("A:A").Select
Selection.NumberFormatLocal = "@"
Range("A1") = "ID"
Range("B1") = "NAME"
row1 = row2
row = row + 1
sheet = sheet + 1
Sheets("乡镇").Select
Loop
End Function
（本文已被浏览 次） | | |
相关评论
