垃圾代码存放
Private Sub Workbook_Open()
If MsgBox("是否拆分为分行Sheet？", vbYesNo, "拆分") = vbYes Then
FindSubBank
End If
End Sub
Sub CreateSheet(sheetName As String, afterSheet As String)
Dim newSheet As Worksheet
Set newSheet = ThisWorkbook.Sheets.Add(after:=Sheets(afterSheet))
With newSheet
.Name = sheetName
End With
End Sub
Sub FindSubBank()
Dim sum As Long
sum = 0
Dim rowsInBank As Long
rowsInBank = 0
Dim bankName As String
Dim nextBankName As String
Do
bankName = ThisWorkbook.Sheets("统计数据").Range("A3").Offset(sum, 0).Value
nextBankName = ThisWorkbook.Sheets("统计数据").Range("A3").Offset(sum + 1, 0).Value
If (sum = 0) Then
CreateSheet bankName, "统计数据"
ThisWorkbook.Sheets("统计数据").Activate
End If
If (bankName <> nextBankName) And sum <> 0 Then
Range("A3").Offset(sum, 0).EntireRow.Copy ThisWorkbook.Sheets(bankName).Range("A3").Offset(rowsInBank, 0)
rowsInBank = 0
CreateSheet nextBankName, bankName
ThisWorkbook.Sheets("统计数据").Activate
Range("A1").EntireRow.Copy ThisWorkbook.Sheets(nextBankName).Range("A1")
Range("A2").EntireRow.Copy ThisWorkbook.Sheets(nextBankName).Range("A2")
Else
Range("A1").EntireRow.Copy ThisWorkbook.Sheets(bankName).Range("A1")
Range("A2").EntireRow.Copy ThisWorkbook.Sheets(bankName).Range("A2")
Range("A3").Offset(sum, 0).EntireRow.Copy ThisWorkbook.Sheets(bankName).Range("A3").Offset(rowsInBank, 0)
rowsInBank = rowsInBank + 1
End If
sum = sum + 1
Loop Until ThisWorkbook.Sheets("统计数据").Range("A3").Offset(sum + 1, 0).Value = ""
End Sub
以前的VBA代码存到移动硬盘中居然都被删掉，郁闷。放到这里应该安全吧。代码很垃圾，但是可能会有用到。这里就当垃圾箱吧。
Sub OpenFiles(strPath As String, strName As String) '搜索分行文件夹依次打开所有同类的调研表
Application.DisplayAlerts = False '关闭
Dim i
If Application.Version = "11.0" Then
'2003版本下打开多个文件代码
With Application.FileSearch
.LookIn = strPath '在统计表格所在目录开始搜索
.SearchSubFolders = True '搜索子文件夹
.fileName = "*" & strName & "*" & ".xls" '搜索文件名包含所选表格名的.xls文件
If .Execute > 0 Then
For i = 1 To .FoundFiles.count
Dim strTemp As String
strTemp = .FoundFiles(i)
Workbooks.Open (.FoundFiles(i))
'重命名该分行文件夹下的调研表名，加上“_分行名”为后缀，然后另存到同目录下
Dim strSub As String
Dim subBank As String
strSub = Application.ActiveWorkbook.path
subBank = Mid(strSub, InStrRev(strSub, "\", Len(strSub)) + 1)
Dim saveasName As String
Dim curName As String
curName = Application.ActiveWorkbook.name '当前文件名
saveasName = Mid(curName, 1, InStrRev(curName, ".", Len(curName)) - 1) & "_" & subBank & ".xls" '另存为文件名
Application.ActiveWorkbook.SaveAs (Application.ActiveWorkbook.path & "\" & saveasName) '另存为
' Application.ActiveWorkBook.ChangeFileAccess xlReadWrite '改变文件的访问方式为“读写”
Worksheets(2).Activate
Next
Else
MsgBox "找不到该文件！请确保统计表格所在路径的正确性！"
End If
End With
ElseIf Application.Version = "12.0" Then
'2007版本下打开多个文件代码
Dim strSubBank(38) As String
strSubBank(0) = "北京分行"
strSubBank(1) = "天津分行"
strSubBank(2) = "河北分行"
strSubBank(3) = "山西分行"
strSubBank(4) = "内蒙分行"
strSubBank(5) = "辽宁分行"
strSubBank(6) = "大连分行"
strSubBank(7) = "吉林分行"
strSubBank(8) = "黑龙江分行"
strSubBank(9) = "上海分行"
strSubBank(10) = "江苏分行"
strSubBank(11) = "苏州分行"
strSubBank(12) = "浙江分行"
strSubBank(13) = "宁波分行"
strSubBank(14) = "安徽分行"
strSubBank(15) = "福建分行"
strSubBank(16) = "厦门分行"
strSubBank(17) = "江西分行"
strSubBank(18) = "山东分行"
strSubBank(19) = "青岛分行"
strSubBank(20) = "河南分行"
strSubBank(21) = "湖北分行"
strSubBank(22) = "三峡分行"
strSubBank(23) = "湖南分行"
strSubBank(24) = "广东分行"
strSubBank(25) = "深圳分行"
strSubBank(26) = "广西分行"
strSubBank(27) = "海南分行"
strSubBank(28) = "重庆分行"
strSubBank(29) = "四川分行"
strSubBank(30) = "贵州分行"
strSubBank(31) = "云南分行"
strSubBank(32) = "西藏分行"
strSubBank(33) = "陕西分行"
strSubBank(34) = "甘肃分行"
strSubBank(35) = "青海分行"
strSubBank(36) = "宁夏分行"
strSubBank(37) = "新疆分行"
Dim xBank As Long
xBank = 0
For xBank = 0 To UBound(strSubBank) - 1
Dim path As String
Dim name As String
path = ThisWorkbook.path
name = Dir(path & "\" & strSubBank(xBank) & "\*" & strName & "*.xls", vbDirectory)
Do While name <> ""
Workbooks.Open path & "\" & strSubBank(xBank) & "\" & name
name = Dir
'重命名该分行文件夹下的调研表名，加上“_分行名”为后缀，然后另存到同目录下
Dim strSub2 As String
Dim subBank2 As String
strSub2 = Application.ActiveWorkbook.path
subBank2 = Mid(strSub2, InStrRev(strSub2, "\", Len(strSub2)) + 1)
Dim saveasName2 As String
Dim curName2 As String
curName2 = Application.ActiveWorkbook.name '当前文件名
saveasName2 = Mid(curName2, 1, InStrRev(curName2, ".", Len(curName2)) - 1) & "_" & subBank2 & ".xls" '另存为文件名
Application.ActiveWorkbook.SaveAs (Application.ActiveWorkbook.path & "\" & saveasName2) '另存为
' Application.ActiveWorkBook.ChangeFileAccess xlReadWrite '改变文件的访问方式为“读写”
Worksheets(2).Activate
Loop
Next
End If
Application.DisplayAlerts = True '打开
End Sub
Application.DisplayAlerts = False '关闭
Dim i
If Application.Version = "11.0" Then
'2003版本下打开多个文件代码
With Application.FileSearch
.LookIn = strPath '在统计表格所在目录开始搜索
.SearchSubFolders = True '搜索子文件夹
.fileName = "*" & strName & "*" & ".xls" '搜索文件名包含所选表格名的.xls文件
If .Execute > 0 Then
For i = 1 To .FoundFiles.count
Dim strTemp As String
strTemp = .FoundFiles(i)
Workbooks.Open (.FoundFiles(i))
'重命名该分行文件夹下的调研表名，加上“_分行名”为后缀，然后另存到同目录下
Dim strSub As String
Dim subBank As String
strSub = Application.ActiveWorkbook.path
subBank = Mid(strSub, InStrRev(strSub, "\", Len(strSub)) + 1)
Dim saveasName As String
Dim curName As String
curName = Application.ActiveWorkbook.name '当前文件名
saveasName = Mid(curName, 1, InStrRev(curName, ".", Len(curName)) - 1) & "_" & subBank & ".xls" '另存为文件名
Application.ActiveWorkbook.SaveAs (Application.ActiveWorkbook.path & "\" & saveasName) '另存为
' Application.ActiveWorkBook.ChangeFileAccess xlReadWrite '改变文件的访问方式为“读写”
Worksheets(2).Activate
Next
Else
MsgBox "找不到该文件！请确保统计表格所在路径的正确性！"
End If
End With
ElseIf Application.Version = "12.0" Then
'2007版本下打开多个文件代码
Dim strSubBank(38) As String
strSubBank(0) = "北京分行"
strSubBank(1) = "天津分行"
strSubBank(2) = "河北分行"
strSubBank(3) = "山西分行"
strSubBank(4) = "内蒙分行"
strSubBank(5) = "辽宁分行"
strSubBank(6) = "大连分行"
strSubBank(7) = "吉林分行"
strSubBank(8) = "黑龙江分行"
strSubBank(9) = "上海分行"
strSubBank(10) = "江苏分行"
strSubBank(11) = "苏州分行"
strSubBank(12) = "浙江分行"
strSubBank(13) = "宁波分行"
strSubBank(14) = "安徽分行"
strSubBank(15) = "福建分行"
strSubBank(16) = "厦门分行"
strSubBank(17) = "江西分行"
strSubBank(18) = "山东分行"
strSubBank(19) = "青岛分行"
strSubBank(20) = "河南分行"
strSubBank(21) = "湖北分行"
strSubBank(22) = "三峡分行"
strSubBank(23) = "湖南分行"
strSubBank(24) = "广东分行"
strSubBank(25) = "深圳分行"
strSubBank(26) = "广西分行"
strSubBank(27) = "海南分行"
strSubBank(28) = "重庆分行"
strSubBank(29) = "四川分行"
strSubBank(30) = "贵州分行"
strSubBank(31) = "云南分行"
strSubBank(32) = "西藏分行"
strSubBank(33) = "陕西分行"
strSubBank(34) = "甘肃分行"
strSubBank(35) = "青海分行"
strSubBank(36) = "宁夏分行"
strSubBank(37) = "新疆分行"
Dim xBank As Long
xBank = 0
For xBank = 0 To UBound(strSubBank) - 1
Dim path As String
Dim name As String
path = ThisWorkbook.path
name = Dir(path & "\" & strSubBank(xBank) & "\*" & strName & "*.xls", vbDirectory)
Do While name <> ""
Workbooks.Open path & "\" & strSubBank(xBank) & "\" & name
name = Dir
'重命名该分行文件夹下的调研表名，加上“_分行名”为后缀，然后另存到同目录下
Dim strSub2 As String
Dim subBank2 As String
strSub2 = Application.ActiveWorkbook.path
subBank2 = Mid(strSub2, InStrRev(strSub2, "\", Len(strSub2)) + 1)
Dim saveasName2 As String
Dim curName2 As String
curName2 = Application.ActiveWorkbook.name '当前文件名
saveasName2 = Mid(curName2, 1, InStrRev(curName2, ".", Len(curName2)) - 1) & "_" & subBank2 & ".xls" '另存为文件名
Application.ActiveWorkbook.SaveAs (Application.ActiveWorkbook.path & "\" & saveasName2) '另存为
' Application.ActiveWorkBook.ChangeFileAccess xlReadWrite '改变文件的访问方式为“读写”
Worksheets(2).Activate
Loop
Next
End If
Application.DisplayAlerts = True '打开
End Sub
