设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 过节不忘提问题，真正的挑战来了，求教hrpotter版主及各 ...
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 2185|回复: 3

[已解决]过节不忘提问题，真正的挑战来了，求教hrpotter版主及各高手

[复制链接]
发表于 2012-9-28 10:33 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
10学分
在“问题”表中，请各位大侠帮忙编写一段代码，把“展开层”这一列里面每一段以“....4”这一行开头的区域单独提取出来，分别以“....4”行里面E列的单元格内容命名，保存ABC文件夹中，万分感谢！！
最佳答案
月排行榜 / 总排行榜
0Mouse
2012-9-28 13:15
试试看！一共生成了66个子文档。
  1. Sub xq()
  2. Application.ScreenUpdating = False
  3. Dim arr, brr, crr, i%, j%, k%, x%, fn$
  4. Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = 4
  5. arr = [A1].CurrentRegion
  6. brr = [A1].Resize(2, UBound(arr, 2))
  7. ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
  8. For i = 3 To UBound(arr)
  9.     If arr(i, 1) Like "*4" Then
  10.         k = k + 1
  11.         If k = 1 Then
  12.             x = x + 1
  13.             For j = 1 To UBound(arr, 2)
  14.                 crr(x, j) = arr(i, j)
  15.             Next
  16.             fn = arr(i, 5)
  17.         End If
  18.         If k = 2 Then
  19.             Worksheets.Add(, Sheets(Sheets.Count)).Name = fn
  20.             With ActiveSheet
  21.                 .[A1].Resize(2, UBound(arr, 2)).Value = brr
  22.                 .[A3].Resize(x, UBound(arr, 2)).Value = crr
  23.                 .[A1].Select
  24.                 .Move
  25.             End With
  26.             ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & fn & ".xlsx", FileFormat:=51
  27.             ActiveWorkbook.Close False
  28.             ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
  29.             For j = 1 To UBound(arr, 2)
  30.                 crr(1, j) = arr(i, j)
  31.             Next
  32.             fn = arr(i, 5)
  33.             k = 1
  34.             x = 1
  35.         End If
  36.     Else
  37.         If k = 1 Then
  38.             x = x + 1
  39.             For j = 1 To UBound(arr, 2)
  40.                 crr(x, j) = arr(i, j)
  41.             Next
  42.         End If
  43.     End If
  44. Next
  45. Cells(Rows.Count, 1).End(xlUp).ClearContents
  46. Application.ScreenUpdating = True
  47. End Sub
复制代码
附件： 问题xq.rar (363.77 KB, 下载次数: 10)

ABC.zip

391.03 KB, 下载次数: 8
挑战, 文件夹

相关帖子

excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
0Mouse
发表于 2012-9-28 13:15 | 显示全部楼层    本楼为最佳答案   
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
试试看！一共生成了66个子文档。
  1. Sub xq()
  2. Application.ScreenUpdating = False
  3. Dim arr, brr, crr, i%, j%, k%, x%, fn$
  4. Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = 4
  5. arr = [A1].CurrentRegion
  6. brr = [A1].Resize(2, UBound(arr, 2))
  7. ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
  8. For i = 3 To UBound(arr)
  9.     If arr(i, 1) Like "*4" Then
  10.         k = k + 1
  11.         If k = 1 Then
  12.             x = x + 1
  13.             For j = 1 To UBound(arr, 2)
  14.                 crr(x, j) = arr(i, j)
  15.             Next
  16.             fn = arr(i, 5)
  17.         End If
  18.         If k = 2 Then
  19.             Worksheets.Add(, Sheets(Sheets.Count)).Name = fn
  20.             With ActiveSheet
  21.                 .[A1].Resize(2, UBound(arr, 2)).Value = brr
  22.                 .[A3].Resize(x, UBound(arr, 2)).Value = crr
  23.                 .[A1].Select
  24.                 .Move
  25.             End With
  26.             ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & fn & ".xlsx", FileFormat:=51
  27.             ActiveWorkbook.Close False
  28.             ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
  29.             For j = 1 To UBound(arr, 2)
  30.                 crr(1, j) = arr(i, j)
  31.             Next
  32.             fn = arr(i, 5)
  33.             k = 1
  34.             x = 1
  35.         End If
  36.     Else
  37.         If k = 1 Then
  38.             x = x + 1
  39.             For j = 1 To UBound(arr, 2)
  40.                 crr(x, j) = arr(i, j)
  41.             Next
  42.         End If
  43.     End If
  44. Next
  45. Cells(Rows.Count, 1).End(xlUp).ClearContents
  46. Application.ScreenUpdating = True
  47. End Sub
复制代码
附件： 问题xq.rar (363.77 KB, 下载次数: 10)

评分

参与人数 1 +5 金币 +5 收起 理由
suye1010 + 5 + 5 赞一个!

查看全部评分

回复

使用道具 举报

发表于 2012-9-28 13:27 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
  1. Sub ExtractContent()
  2. Dim i As Integer, LastRow As Integer, wb As Workbook
  3. Application.ScreenUpdating = False
  4. LastRow = Cells(65536, 1).End(xlUp).Row
  5. For i = 3 To LastRow
  6.     If Cells(i, 1) = "....4" Then
  7.         Set wb = Workbooks.Add
  8.         Range("A1:T2").Copy wb.Sheets(1).Range("A1:T2")
  9.         Range("A" & i & ":T" & i).Copy wb.Sheets(1).Range("A" & i & ":T" & i)
  10.         wb.Close True, ThisWorkbook.Path & Application.PathSeparator & Cells(i, 5) & ".xls"
  11.     End If
  12. Next i
  13. Application.ScreenUpdating = True
  14. End Sub
复制代码
问题.zip (231.83 KB, 下载次数: 2)
回复

使用道具 举报

 楼主| 发表于 2012-9-28 13:50 | 显示全部楼层
非常感谢高手帮助，但是好像第26行运行到后面的时候会报错，你可以用这个文件再试一下

新建文件夹.zip

156 Bytes, 下载次数: 2

点评

suye1010
文件夹没有内容！另如果你下载了上贴中的附件运行过的话，你会发现可以正常运行！得到66个文件，且运行速度优于2楼。  发表于 2012-9-28 17:22
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-5-13 19:12 , Processed in 0.322680 second(s), 16 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表