垃圾代码存放

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

转载于:https://www.cnblogs.com/Jinspet/archive/2009/02/25/1397893.html