请赵版、群子等大侠教我做两个循环，一个用于手工填写，一个用于高级筛选
阅读权限50
在线时间 小时
& & & & & & & &
朱荣兴 发表于
Sub 按单位高级筛选()
For i = 2 To Sheet1.[a65536].End(3).Row
高级筛选所需的条件区域要求是连续单元格，由于它引用Range(&C1:C2&)，所以前面的Range(&C2&)不变。
即：Range(&C2&) = Range(&A& & i) & & * &
不是Range(&C& & i) = Range(&A& & i) & & * &
另外，我希望筛选完一个，就保存一个，每次保存的文件夹、文件名、工作表名、页眉都随之变化。
我试着用嵌套循环，搞错了。
阅读权限95
在线时间 小时
shenghua8 发表于
哦，要数据源和最后效果。
第一个循环已经在朱荣兴老师的指导下完成。
ADO生成工作簿请测试：Sub Macro1()
& & Dim cnn As Object, arr, i&, SQL$, MyPath$, p$, f$
& & Set cnn = CreateObject(&ADODB.Connection&)
& & MyPath = ThisWorkbook.Path & &\&
& & cnn.Open &Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=& & ThisWorkbook.FullName
& & arr = Range(&A1&).CurrentRegion
& & For i = 2 To UBound(arr)
& && &&&p = MyPath & arr(i, 1) & &\&
& && &&&If Dir(p, vbDirectory) = && Then MkDir p
& && &&&f = p & arr(i, 2) & &.xls&
& && &&&If Dir(f) && && Then Kill f
& && &&&SQL = &select * into [Excel 8.0;Database=& & f & &].& & arr(i, 2) & & from (select * from [列表区域$] where left(个人代码,3)='& & arr(i, 1) & &')&
& && &&&cnn.Execute SQL
& & Next
& & cnn.Close
& & Set cnn = Nothing
& & MsgBox &ok&
End Sub
复制代码
阅读权限95
在线时间 小时
ADO法不会保留格式，如果要保留格式需要重写
(11 KB, 下载次数: 4)
18:36 上传
点击文件名下载附件
阅读权限50
在线时间 小时
zhaogang1960 发表于
ADO法不会保留格式，如果要保留格式需要重写
首先谢谢赵版。
您教过我很多。
您这个代码能将这篇帖子的例子效果实现出来，除了格式之外。
事实上，这个我有一大摊子表，其它代码都完成且测试通过，现在想要再完善一下，让它们实现一键自动化，
然后需要一个循环，将我以前的代码都 Call 进来。包括格式都是重要的。
您写的这个代码我理解起来还有难度，更别说 Call 进来。
我先慢慢磨叽一下。您先忙。
阅读权限95
在线时间 小时
& & & & & & & &
shenghua8 发表于
首先谢谢赵版。
您教过我很多。
您这个代码能将这篇帖子的例子效果实现出来，除了格式之外。
如果不好理解，请测试下面字典法：Sub 字典法()
& & Dim arr, brr, sh As Worksheet, d As Object, k, t, a, i&, j&, m&, l&, r&, s$
& & Application.ScreenUpdating = False
& & Application.DisplayAlerts = False
& & Set d = CreateObject(&scripting.dictionary&)
& & arr = [a1].CurrentRegion
& & For i = 2 To UBound(arr)
& && &&&d(arr(i, 1)) = arr(i, 2)
& & Next
& & Set sh = Sheets(&列表区域&)
& & arr = sh.[a1].CurrentRegion
& & For i = 2 To UBound(arr)
& && &&&s = Left$(arr(i, 1), 3)
& && &&&If d.Exists(s) Then d(s) = d(s) & &,& & i
& & Next
& & k = d.Keys
& & t = d.Items
& & brr = arr
& & MyPath = ThisWorkbook.Path & &\&
& & For i = 0 To d.Count - 1
& && &&&m = 0
& && &&&a = Split(t(i), &,&)
& && &&&If UBound(a) & 1 Then
& && && && &p = MyPath & k(i) & &\&
& && && && &If Dir(p, vbDirectory) = && Then MkDir p
& && && && &For j = 1 To UBound(a)
& && && && && & m = m + 1
& && && && && & r = a(j)
& && && && && & For l = 1 To UBound(arr, 2)
& && && && && && &&&brr(m, l) = arr(r, l)
& && && && && & Next
& && && && &Next
& && && && &sh.Copy
& && && && &With ActiveWorkbook
& && && && && & With .ActiveSheet
& && && && && && &&&.UsedRange.Offset(1).ClearContents
& && && && && && &&&.[a2].Resize(m, l - 1) = brr
& && && && && && &&&.Name = a(0)
& && && && && & End With
& && && && && & .Close True, p & a(0) & &.xls&
& && && && &End With
& && &&&End If
& & Next
& & Application.ScreenUpdating = True
& & MsgBox &ok&
End Sub
复制代码
阅读权限95
在线时间 小时
两种方法都在附件中，请测试：
(12.77 KB, 下载次数: 8)
19:20 上传
点击文件名下载附件
阅读权限50
在线时间 小时
zhaogang1960 发表于
如果不好理解，请测试下面字典法：
不好意思，我还是让赵版失望了。还是看不懂。{:soso_e100:}
赵版对坛友无微不至，对新人也不例外。
因为您的程序太高深，我又只能看简单的，所以经过我磨叽之后，想了个其它的法子。
既然我用嵌套循环不对，也许还要条件语句什么的，更难动脑筋，那就只用一层吧，变量只用一个，
这么一想，才发现，其实我有要求只需一个变量，一层循环。
于是我做了下边这个，可能还有很多不正确的地方，我先试用，然后慢慢修正问题。
赵版的两个程序，我只能等慢慢进步后，再回来欣赏。十分感谢！{:soso_e183:}
我改成如下这样了：
Dim XiaYiGe
Sub 手工填写单位名称()
Sheets(&条件区域&).Select
For XiaYiGe = 2 To Sheets(&条件区域&).Range(&A& & Rows.Count).End(xlUp).Row
Range(&B& & XiaYiGe).Select
Range(&B& & XiaYiGe).Value = InputBox(&请根据代码填写单位名称&)
Next
End Sub
Sub 按单位分个人信息()
For XiaYiGe = 2 To Sheets(&条件区域&).Range(&A& & Rows.Count).End(xlUp).Row
Call 按单位高级筛选
Call 其他子程序
Call 按单位名称保存
Next
End Sub
Sub 按单位高级筛选()
Sheets(&条件区域&).Select
Range(&C2&) = Range(&A& & XiaYiGe) & &*&
Sheets(&筛选结果&).Select
Cells.ClearContents '先将“筛选结果”工作表清除干净
Range(&A3&).Select
Sheets(&列表区域&).Cells.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
Sheets(&条件区域&).Range(&C1:C2&), CopyToRange:=Range(&A1&), Unique:=False '执行高级筛选
Range(&A2&).Select
Sheets(&条件区域&).Select
Range(&C2&).Select
End Sub
Sub 其他子程序()
'MsgBox &还有一些其他子程序&
End Sub
Sub 按单位名称保存()
Sheets(&筛选结果&).Copy
ActiveSheet.Name = ThisWorkbook.Sheets(&条件区域&).Range(&B& & XiaYiGe).Value
ActiveSheet.PageSetup.CenterHeader = &&&&宋体,加粗&&&18 & & ThisWorkbook.Sheets(&条件区域&).Range(&B& & XiaYiGe).Value & &成员信息表&
On Error Resume Next
Application.DisplayAlerts = False
MkDir ThisWorkbook.Path & &\& & ThisWorkbook.Sheets(&条件区域&).Range(&A& & XiaYiGe).Value
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & &\& & ThisWorkbook.Sheets(&条件区域&).Range(&A& & XiaYiGe).Value & &\& & ThisWorkbook.Sheets(&条件区域&).Range(&B& & XiaYiGe).Value & &.xls&
ActiveWindow.Close True '新文件保存退出
End Sub
复制代码
(12.71 KB, 下载次数: 10)
19:52 上传
点击文件名下载附件
阅读权限50
在线时间 小时
朱荣兴 发表于
Sub 按单位高级筛选()
For i = 2 To Sheet1.[a65536].End(3).Row
感谢朱老师的这一句：
Range(&C& & i) = Range(&a& & i) & & * &
我改成了：
& & Range(&C2&) = Range(&A& & i) & &*&
正是从这一句我才发现，其实我想要的只需一个变量、一层循环。
阅读权限95
在线时间 小时
& & & & & & & &
shenghua8 发表于
不好意思，我还是让赵版失望了。还是看不懂。
赵版对坛友无微不至，对新人也不例外。
如果确实不愿意用数组+字典，建议用一个很好理解的方法：
历遍条件区域表的所有行，用Find方法循环查找列表区域表A列，逐行复制到一个空表中，等你复制完毕就可以保存为工作簿了，而不是再加一层循环
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师