楼主 罗刚君 |
提示:此题目是“VBA入门免费教学群”(群号:30729794)的课后作业 请未参与听课者绕道,谢谢配合。 _____________________________________________________ 附件的工作簿中包含若干个工作表,每个工作表中有若干行数据,要求使用循环语句将所有工作表中包含“刀”的资料筛选出来,存放在新工作表中。 思路请参考上课时讲的的案例3。 第24课作题一.rar 补充: 1.请不要使用数组的知识。 2.本周作业答案最优秀者有丰厚奖品,下周公布。_____________________________________________________ 补充:“VBA入门免费教学群”(群号:30729794)每周三上课一次,有兴趣者皆可报名,永远免费。 请提交作业时注明在免费听课群的昵称。三次不交作业者,将踢出群,让出空间让更多的人进来听课,请大家配合 _______ 第23课作题答案.rar |
2楼 liaozhifa33 |
宁静致远 find还没弄明白,换个方式了, 【思路是对各个表筛选“*刀”,复制到“汇总”表】 已经避免的几个问题:已存在汇总表的删除问题;存在空表的问题(删除);自定义查找问题。 '=========================================================================== Sub 复制查找到的内容到汇总表() Application.ScreenUpdating = False Application.DisplayAlerts = False Dim findstr As String '声明自定义查找字符 findstr = "*" & Application.InputBox("请输入需要查找的物品的名称或包含的字", "查找", "刀", , , , , 2) & "*" '=========删除汇总表(如果存在)== On Error Resume Next Sheets("汇总").Delete '删除汇总表 '=========新建汇总表============== Sheets.Add after:=Sheets(Sheets.Count): Sheets(Sheets.Count).Name = "汇总" '新建一个工作表 Range("a1:d1") = Array("姓名", "工号", "产品", "数量") '写入列标题 '=========在各表中循环查找======== For Each sht In Sheets If sht.Name = "汇总" Then Exit For '禁止在汇总表中查找 If WorksheetFunction.CountA(sht.Cells) = 0 Then sht.Delete '如果为空表,则删除空表(当然也可以跳过哈) sht.AutoFilterMode = False '取消表格的筛选状态 ' sht.Range("A:D").AutoFilter Field:=3, Criteria1:="*刀", Operator:=xlFilterValues '查找“*刀“(固定了查找条件) sht.Range("A:D").AutoFilter Field:=3, Criteria1:=findstr, Operator:=xlFilterValues '查找“*刀“(用户自定义查找) '复制到汇总表 sht.UsedRange.Offset(1, 0).Copy Worksheets("汇总").Cells(Range("a65536").End(xlUp).Row + 1, "A") sht.AutoFilterMode = False '取消表格的筛选状态 Next '=========设置汇总表格式========== If Len(Worksheets("汇总").Range("A2")) <> 0 Then '如果有数据则设置格式 With Range("A1").CurrentRegion .Borders.LineStyle = 1 '对已用区域添加边框 .EntireColumn.AutoFit '自动调整列宽 .HorizontalAlignment = xlCenter '水平居中 .VerticalAlignment = xlCenter '垂直居中 End With With Range("A1:D1") '设置标题格式 .Interior.Color = 10066176 .Font.ThemeColor = xlThemeColorDark1 End With MsgBox "共找到 " & WorksheetFunction.CountA(Range("c:c")) - 1 & " 条符合条件的数据!" Else Worksheets("汇总").Delete: MsgBox "没有找到符合条件的数据!" '没有数据就删除表格 End If Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub '=========================================================================== |
3楼 kcxs |
客城小生--本课(第23课)的作业
|
4楼 wendel |
写错了,该楼请老师删除吧 |
5楼 wendel |
无心手语
|
6楼 paoge |
骑着钓箱看世界 Sub 查找符合条件的单元格() Dim rng As Range, sht As Worksheet, FirstAddress As String, Findcount As Integer For Each sht In Worksheets Set rng = sht.UsedRange.Find("*刀") If Not rng Is Nothing Then FirstAddress = rng.Address Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = sht.Name & "查找结果" Range("a1:d1") = Array("姓名", "工号", "生产产品", "数量") Do Set rng = sht.UsedRange.Find("*刀", rng, , xlWhole) Findcount = Findcount + 1 rng.Offset(0, -2).Resize(1, 4).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) If rng.Address = FirstAddress Then Exit Do Loop ActiveSheet.UsedRange.Borders.LineStyle = 1 ActiveSheet.UsedRange.EntireColumn.AutoFit Else MsgBox "单元格没找到!", vbInformation, "提示" End If Next sht End Sub |
7楼 爱情和面包 |
Sub Text() Dim Fd As Range, Rng As Range, UR As Range, i As Byte Worksheets.Add after:=Worksheets(Worksheets.Count) Range("a1:d1") = Array("姓名", "工号", "产品", "数量") For i = 1 To Worksheets.Count - 1 Sheets(i).Select Set Fd = Nothing With Intersect(Sheets(i).UsedRange, [C:C]) Set Fd = .Find("刀", , , xlPart) If Not Fd Is Nothing Then '如果已经找到 Set Rng = Fd Set UR = Fd Do Set Rng = .Find("刀", Rng, , xlPart) Set UR = Union(UR, Rng) Rng.Offset(0, -2).Resize(1, 4).Copy Sheets(Sheets.Count).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) If Rng = Fd Then Exit Do Loop End If End With Next Sheets(Sheets.Count).Select End Sub |
8楼 mmice |
Option Explicit Sub 多表查找并汇总() Dim rng As Range, FirstAddress As String, sht As Worksheet, FindCount As Integer '声明变量 Application.DisplayAlerts = False Set sht = ActiveSheet '将活动工作表赋予变量 Set rng = ActiveSheet.UsedRange.Find("*刀") '在已用区域中查找“*刀” 'If Not rng Is Nothing Then '如果已经找到 'FirstAddress = rng.Address '记录下这个单元格的址 Worksheets.Add After:=Worksheets(Worksheets.Count) '新建一个工作表 Range("a1:d1") = Array("姓名", "工号", "产品", "数量") '写入列标题 For Each sht In Worksheets If sht.Name <> ActiveSheet.Name Then Set rng = sht.UsedRange.Find("*刀") '在已用区域中查找“*刀” If Not rng Is Nothing Then '如果已经找到 FirstAddress = rng.Address '记录下这个单元格的址 Do Set rng = sht.UsedRange.Find("*刀", rng, , xlWhole) '继续查找(上一次找到的单元格后面开始查找) FindCount = FindCount + 1 '累加计数器 '找到目标后,将目标所在行的4个单元格一起复制到新工作表中去(从上到下按顺序罗列) rng.Offset(0, -2).Resize(1, 4).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) '如果当前找到的目标单元格地址等于第一次记录的单元格地址,那么结束循环 If rng.Address = FirstAddress Then Exit Do Loop ActiveSheet.UsedRange.Borders.LineStyle = 1 '对已用区域添加边框 ActiveSheet.UsedRange.EntireColumn.AutoFit '自动调整列宽 'MsgBox "贺喜,找到" & FindCount & "条记录。", vbOKOnly + vbInformation, "开心" 'Else 'MsgBox "兄弟,对不住啊,一个都没有找到!", vbOKOnly + vbInformation, "痛苦流涕" End If End If Next FindCount = FindCount MsgBox "贺喜,找到" & FindCount & "条记录。", vbOKOnly + vbInformation, "开心" Application.DisplayAlerts = True End Sub 小白 |
9楼 LurYangHer |
VBA入门免费教学群 @[粤]-BatisHe Sub 筛选含刀的数据() Dim Sht As Worksheet Dim rng As Range Dim ShtFstAdd As String Dim i As Byte, N As Byte, FindCount As Integer i = 1 N = Sheets.Count Do Set Sht = Sheets(i) Set rng = Sht.UsedRange.Find("*刀*") If Not rng Is Nothing Then ShtFstAdd = rng.Address Do While Not rng Is Nothing FindCount = FindCount + 1 If FindCount = 1 Then Sheets.Add after:=Worksheets(Worksheets.Count) Sheets(Sheets.Count).Name = "筛选含刀的数据" Range("A1:E1") = Array("姓名", "工号", "产品", "数量", "生产线") End If rng.Offset(0, -2).Resize(1, 4).Copy Sheets(N + 1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) Cells(Sheets(N + 1).UsedRange.Rows.Count, 5).Value = Sheets(i).Name Set rng = Sht.UsedRange.Find("刀", rng, , xlPart) If ShtFstAdd = rng.Address Then Exit Do Loop i = i + 1 Loop Until i = N + 1 If FindCount > 0 Then Sheets(N + 1).UsedRange.Borders.LineStyle = 1 Sheets(N + 1).UsedRange.EntireColumn.AutoFit MsgBox "找到 " & FindCount & " 条记录!", vbInformation + vbOKOnly, "信息提示" Else MsgBox "没找到含“刀”的记录!", vbInformation + vbOKOnly, "信息提示" End If End Sub |
10楼 一片叶子 |
|
11楼 manuel442 |
QQ昵称:智山仁水 Sub 筛选刀的信息() Dim rng As Range, FirstAddress As String, sht As Worksheet, FindCount As Integer, i As Integer, shtcount As Integer, b As Boolean '声明变量 shtcount = Worksheets.Count For Each sht In Worksheets Set rng = sht.UsedRange.Find("*刀") b = (Not rng Is Nothing) + b Next If b Then Worksheets.Add after:=Worksheets(Worksheets.Count) '新建一个工作表 Range("a1:d1") = Array("姓名", "工号", "产品", "数量") '写入列标题 For i = 1 To shtcount Set rng = Worksheets(i).UsedRange.Find("*刀") '在已用区域中查找"*刀" If Not rng Is Nothing Then '如果已经找到 FirstAddress = rng.Address '记录下这个单元格的址 Do '启动循环 Set rng = Worksheets(i).UsedRange.Find("*刀", rng, , xlWhole) '继续查找(上一次找到的单元格后面开始查找) FindCount = FindCount + 1 '累加计数器 '找到目标后,将目标所在行的4个单元格一起复制到新工作表中去(从上到下按顺序罗列) rng.Offset(0, -2).Resize(1, 4).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) '如果当前找到的目标单元格地址等于第一次记录的单元格地址,那么结束循环 If rng.Address = FirstAddress Then Exit Do Loop End If Next ActiveSheet.UsedRange.Borders.LineStyle = 1 '对已用区域添加边框 ActiveSheet.UsedRange.EntireColumn.AutoFit '自动调整列宽 MsgBox "贺喜,找到" & FindCount & "条记录。", vbOKOnly + vbInformation, "开心" Else MsgBox "没有找到记录", vbOKOnly End If End Sub |
12楼 ch_liu2000 |
浪迹天涯24课作业 第24课作题.rar |
13楼 冰淇林的冬天 |
群号:30729794 冰淇淋的冬天 第24课作题一.rar |
14楼 大猫 |
不能算自己的,抄老师的 第24课作题一大猫作用业.rar 用For Each .. In ...做了个,好象也行的 Sub rr2() Dim rg As Range, i%, rg2 As Range, rg1 As Range, X% X = Worksheets.Count Worksheets.Add(After:=Worksheets(X)).Name = "做刀的人" Range("a1:d1") = Array("姓名", "工号", "产品", "数量") For i = 1 To X Set rg1 = Sheets(i).UsedRange For Each rg In rg1 Set rg2 = rg.Find("*刀", rg) If Not rg2 Is Nothing Then rg.Offset(0, -2).Resize(1, 4).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) End If Next Next End Sub |
15楼 gaoshuichang1 |
社区ID:gaoshuichang1昵称:顺眼了 Sub test() Dim rng As Range, FirstAddress As String, FindCount As Integer, i% '声明变量 If Worksheets.Count > 4 Then Exit Sub Worksheets.Add after:=Worksheets(Worksheets.Count) '新建一个工作表 Range("a1:d1") = Array("姓名", "工号", "产品", "数量") '写入列标题 For i = 1 To 4 Set rng = Sheets(i).UsedRange.Find("*刀") '在已用区域中查找“*刀” If Not rng Is Nothing Then '如果已经找到 FirstAddress = rng.Address '记录下这个单元格地址 Do '启动循环 Set rng = Sheets(i).UsedRange.Find("*刀", rng, , xlWhole) '继续查找(上一次找到的单元格后面开始查找) FindCount = FindCount + 1 '累加计数器 '找到目标后,将目标所在行的4个单元格一起复制到新工作表中去(从上到下按顺序罗列) rng.Offset(0, -2).Resize(1, 4).Copy ActiveSheet.Cells(FindCount + 1, 1) '如果当前找到的目标单元格地址等于第一次记录的单元格地址,那么结束循环 If rng.Address = FirstAddress Then Exit Do Loop End If Next ActiveSheet.UsedRange.Borders.LineStyle = 1 '对已用区域添加边框 ActiveSheet.UsedRange.EntireColumn.AutoFit '自动调整列宽 End Sub 第24课作题一(1).zip |
16楼 静思雨 |
Sub test() Dim sht As Worksheet Dim i As Long Dim j As Long On Error Resume Next Application.DisplayAlerts = False Application.ScreenUpdating = False Sheets("合计").Delete With Sheets.Add(After:=Sheets(Sheets.Count)) .Name = "合计" With .Range("A1:D1") .Value = Array("姓名", "工号", "生产产品", "数量") .Borders.LineStyle = xlContinuous .HorizontalAlignment = xlCenter End With End With j = 1 For Each sht In ThisWorkbook.Worksheets Debug.Print sht.Name If sht.Name <> "合计" Then i = 2 Do If sht.Cells(i, 3) Like "*刀*" Then j = j + 1 sht.Cells(i, 1).Resize(1, 4).Copy Destination:=Sheets("合计").Cells(j, 1) End If i = i + 1 Loop Until sht.Cells(i, 3) = "" End If Next MsgBox "已经统计完成,一共找到" & j - 1 & "条符合条件的记录。" Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub |
17楼 杭州小菜02 |
Sub 查找多表生产刀的员工明细且格式一致() Dim Rng As Range, rngg As Range, j As Integer, i As Integer Worksheets.Add(before:=Sheet1).Name = "生产刀的员工明细" '方法2:Range("a1:d1").Value = [{"姓名","工号","生产产品","产量"}] 还要设置格式较麻烦 With Worksheets("生产刀的员工明细") Worksheets("A线").Range("a1:d1").Copy .Range("a1:d1") For Each Sht In Worksheets ’本例也可以采用FOR..NEXT,j的变量就是备用的 With Sht.UsedRange Set Rng = .Find("刀", , , xlPart) Set rngg = Rng 'rngg也可以用文本型,同时需修改声明的数据类型 If Not Rng Is Nothing Then Do i = i + 1 Set Rng = .FindNext(Rng) Cells(i + 1, 1) = Rng.Offset(0, -2).Value Cells(i + 1, 2) = Rng.Offset(0, -1).Value Cells(i + 1, 3) = Rng.Value Cells(i + 1, 4) = Rng.Offset(0, 1).Value Loop While Rng.Address <> rngg.Address End If End With Next Worksheets("A线").UsedRange.Offset(1, 0).Copy .Range("a2:d" & Cells(Rows.Count, 1).End(xlUp).Row).PasteSpecial _ Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False .UsedRange.Columns("a:d").EntireColumn.AutoFit End With End Sub |
18楼 ynzsvt |
Sub test() Dim rng As Range, FirstAddress As String, sht As Worksheet, FindCount As Integer, i% '声明变量 '调试用语句 Application.DisplayAlerts = False Sheets(Sheets.Count).Delete Application.DisplayAlerts = True Worksheets.Add after:=Worksheets(Worksheets.Count) '新建一个工作表 Range("a1:d1") = Array("姓名", "工号", "产品", "数量") '写入列标题 For i = 1 To Worksheets.Count - 1 Set sht = Sheets(i) '将活动工作表赋予变量 Set rng = Sheets(i).UsedRange.Find("*刀") '在已用区域中查找“*刀” If Not rng Is Nothing Then '如果已经找到 FirstAddress = rng.Address '记录下这个单元格的址 Do '启动循环 FindCount = FindCount + 1 '累加计数器 '找到目标后,将目标所在行的4个单元格一起复制到新工作表中去(从上到下按顺序罗列) rng.Offset(0, -2).Resize(1, 4).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) '如果当前找到的目标单元格地址等于第一次记录的单元格地址,那么结束循环 Set rng = sht.UsedRange.Find("*刀", rng, , xlWhole) '继续查找(上一次找到的单元格后面开始查找) Loop While rng.Address <> FirstAddress End If Next i ActiveSheet.UsedRange.Borders.LineStyle = 1 '对已用区域添加边框 ActiveSheet.UsedRange.EntireColumn.AutoFit '自动调整列宽 If FindCount > 0 Then MsgBox "贺喜,找到" & FindCount & "条记录。", vbOKOnly + vbInformation, "开心" Else MsgBox "兄弟,对不住啊,一个都没有找到!", vbOKOnly + vbInformation, "痛苦流涕" End If End Sub |
19楼 lfwxszw |
群名片:简单 Sub Finddao() '关闭提示 Application.DisplayAlerts = False '容错 On Error Resume Next '定义变量 Dim rng As Range, firstaddress As String, sht As Worksheet '如果最后一个表名是“汇总”,则删除 If Worksheets(Worksheets.Count).Name = "汇总" Then Worksheets(Worksheets.Count).Delete '在最后一表后添加新表,表名为“汇总” Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "汇总" '生成标题行 Range("a1:d1") = Array("姓名", "工号", "产品", "数量") '加边框 Range("a1:d1").Borders.LineStyle = xlContinuous '变量I赋值为除“汇总”表外的所有 For i = 1 To Worksheets.Count - 1 '赋值sht为第i个表 Set sht = Worksheets(i) '赋值rng为第i个表已用区域中含有“刀”字的单元格 Set rng = sht.UsedRange.Find("*刀") '如果rng不是空,找到含有“刀”的值 If Not rng Is Nothing Then '赋值firstaddress为“刀”的地趣 firstaddress = rng.Address '开始 Do '重新定义rng值为表已用区域查找“刀” Set rng = sht.UsedRange.Find("*刀", rng, , xlWhole) '找到后左移2列,然后重置区域为1行4列(已用的区域) 复制 到 汇总表1列最后一个非空单元格的下一格 rng.Offset(0, -2).Resize(1, 4).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) '如果找到最后目标 和 第一次目标地址一样,则 If rng.Address = firstaddress Then Exit Do Loop End If '下一个表 Next '如果rng是空,删除汇总表 If rng Is Nothing Then MsgBox "未找到您要查询的内容": Worksheets(Worksheets.Count).Delete '开启提示 Application.DisplayAlerts = True End Sub |
20楼 本人号被盗, |
Sub 汇总() Dim rng As Range, FirstAddress As String, sht As Worksheet, FindCount As Integer '声明变量 Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "汇总" '新建一个工作表 Range("a1:d1") = Array("姓名", "工号", "产品", "数量") '写入列标题 For i = 1 To Sheets.Count - 1 Sheets(i).Select Set sht = ActiveSheet '将活动工作表赋予变量 Set rng = ActiveSheet.UsedRange.Find("*刀") '在已用区域中查找“*刀” If Not rng Is Nothing Then '如果已经找到 FirstAddress = rng.Address '记录下这个单元格的址 Do '启动循环 Set rng = sht.UsedRange.Find("*刀", rng, , xlWhole) '继续查找(上一次找到的单元格后面开始查找) FindCount = FindCount + 1 '累加计数器 '找到目标后,将目标所在行的4个单元格一起复制到新工作表中去(从上到下按顺序罗列) rng.Offset(0, -2).Resize(1, 4).Copy Worksheets(Sheets.Count).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) '如果当前找到的目标单元格地址等于第一次记录的单元格地址,那么结束循环 If rng.Address = FirstAddress Then Exit Do Loop ActiveSheet.UsedRange.Borders.LineStyle = 1 '对已用区域添加边框 ActiveSheet.UsedRange.EntireColumn.AutoFit '自动调整列宽 Else End If Next MsgBox "贺喜,找到" & FindCount & "条记录。", vbOKOnly + vbInformation, "开心" End Sub |
21楼 本人号被盗, |
|
22楼 一点点 |
在课件案例代码上修改的。达到效果了也应该算数吧 |
23楼 lb425319789 |
经测试,完全实现本次作业要求。 Sub 查找() Dim i As Integer, rng As Range, firstaddress As String, findcount As Integer Worksheets.Add after:=Worksheets(Worksheets.Count) '在最后新建一个工作表 Range("a1:d1") = Array("姓名", "工号", "产品", "数量") '写入列标题 For i = 1 To Worksheets.Count - 1 '循环从第一张表到倒数第二张表 Worksheets(i).Activate '激活第i张工作表 Set sht = ActiveSheet '将活动工作表赋予变量 Set rng = ActiveSheet.UsedRange.Find("*刀") '在活动单元格使用区域中查找带“刀”的单元格 If Not rng Is Nothing Then '如果找到 firstaddress = rng.Address '记录这个单元格的地址 Do '启动循环 Set rng = sht.UsedRange.Find("*刀", rng, , xlWhole) '继续查找带“刀”的单元格,从上一次找到的单元格后面开始查找。 findcount = findcount + 1 '计数器累加 '找到目标后,将目标所在行的4个单元格一起复制到新工作表中(从上到下顺序罗列) rng.Offset(0, -2).Resize(1, 4).Copy Worksheets(Worksheets.Count).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) '如果当前找到的目标单元格地址等于第一次记录的单元格地址,那么结束循环。 If rng.Address = firstaddress Then Exit Do Loop ActiveSheet.UsedRange.Borders.LineStyle = 1 '对已用区域添加边框 ActiveSheet.UsedRange.EntireColumn.AutoFit '自动调整列宽 MsgBox "共找到" & findcount & "条记录" Else MsgBox "没有找到" End If Next End Sub |
24楼 twozisan |
ID:板桥-大刘 Sub 跨工作表引用內容() Dim irow As Integer Dim SHT As Worksheet On Error Resume Next M = 0 Set SHT = Sheets("有(刀)") If SHT <> 0 Then Sheets.Add BEFORE:=Sheets(1) Sheets(1).Name = "有(刀)" Else Sheets("有(刀)").CELL.Clear Sheets("有(刀)").Select End If For i = 2 To Sheets.Count Sheets(i).Select A = [A65536].End(xlUp).Row '定義a為A列最後一個非空儲存格。 For irow = 2 To A answer = Application.WorksheetFunction.Find("刀", Cells(irow, 3)) If answer > 0 Then M = M + 1 Range(Cells(irow, 1), Cells(irow, 4)).Copy Sheets("有(刀)").Cells(M + 1, 1) answer = 0 End If Next irow Next Sheets("有(刀)").[A1] = "姓名" Sheets("有(刀)").[B1] = "工號" Sheets("有(刀)").[C1] = "生產產品" Sheets("有(刀)").[D1] = "數量" Sheets("有(刀)").Select End Sub |
25楼 wangxf9209 |
江苏-雪峰
|