ExcelTip.Net留存知识帖 ---【注：附件之前被网盘供应商清空后，现已修复-现已修复-现已修复为本地下载！】
现在位置：首页 > 我的测验 > Excel VBA > 【罗刚君VBA免费课作业题】之第23课作业

【罗刚君VBA免费课作业题】之第23课作业

作者：绿色风 分类： 时间：2022-08-18 浏览：120
楼主
罗刚君		 提示：此题目是“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课)的作业
  1. Sub test()
  2.   Dim i As Byte, rng As Range, FirstAddress As String, sht As Worksheet, FindCount As Integer '声明变量
  3.     Worksheets.Add after:=Worksheets(Worksheets.Count)  '新建一个工作表
  4.     Range("a1:d1") = Array("姓名", "工号", "生产产品", "数量")  '写入列标题
  5.   For i = 1 To Worksheets.Count - 1 '遍历除最后一个表的每个工作表
  6.       Set sht = Worksheets(i)
  7.       Set rng = sht.UsedRange.Find("*刀")  '在已用区域中查找"*刀"
  8.       If Not rng Is Nothing Then  '如果已经找到
  9.         FirstAddress = rng.Address  '记录下这个单元格的址
  10.         Do  '启动循环
  11.           Set rng = sht.UsedRange.Find("*刀", rng, , xlWhole)  '继续查找（上一次找到的单元格后面开始查找)
  12.           FindCount = FindCount + 1  '累加计数器
  13.     '找到目标后，将目标所在行的4个单元格一起复制到新工作表中去(从上到下按顺序罗列)
  14.           rng.Offset(0, -2).Resize(1, 4).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
  15.           '如果当前找到的目标单元格地址等于第一次记录的单元格地址，那么结束循环
  16.           If rng.Address = FirstAddress Then Exit Do
  17.       Loop
  18.         ActiveSheet.UsedRange.Borders.LineStyle = 1  '对已用区域添加边框
  19.         ActiveSheet.UsedRange.EntireColumn.AutoFit  '自动调整列宽
  20.       End If
  21.   Next
  22.       If FindCount > 0 Then
  23.         MsgBox "贺喜，在工作表找到" & FindCount & "条记录。", vbOKOnly + vbInformation, "开心"
  24.       Else
  25.         MsgBox "兄弟，对不住啊，一个都没有找到！", vbOKOnly + vbInformation, "痛苦流涕"
  26.       End If
  27. End Sub
0
4楼
wendel		 写错了，该楼请老师删除吧
5楼
wendel		 无心手语
  1. Sub test()
  2.   Dim rng As Range, FirstAddress As String, sht As Worksheet, FindCount As Integer  '声明变量
  3.   
  4.   For Each sht In Sheets
  5.     If sht.Name <> "查询结果表" Then
  6.           'Set sht = ActiveSheet  '将活动工作表赋予变量
  7.           Set rng = sht.UsedRange.Find("*刀")  '在已用区域中查找"*刀"
  8.           If Not rng Is Nothing Then  '如果已经找到
  9.             FirstAddress = rng.Address  '记录下这个单元格的址
  10.             On Error Resume Next
  11.             Err.Clear
  12.             Sheets("查询结果表").Select
  13.             If Err() > 0 Then
  14.                 Worksheets.Add After:=Worksheets(Worksheets.Count) '新建一个工作表
  15.                 ActiveSheet.Name = "查询结果表"
  16.                 Range("a1:d1") = Array("姓名", "工号", "产品", "数量")  '写入列标题
  17.             End If
  18.             
  19.             Do  '启动循环
  20.               Set rng = sht.UsedRange.Find("*刀", rng, , xlWhole)  '继续查找（上一次找到的单元格后面开始查找)
  21.               FindCount = FindCount + 1  '累加计数器
  22.         '找到目标后，将目标所在行的4个单元格一起复制到新工作表中去(从上到下按顺序罗列)
  23.               rng.Offset(0, -2).Resize(1, 4).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
  24.               '如果当前找到的目标单元格地址等于第一次记录的单元格地址，那么结束循环
  25.               If rng.Address = FirstAddress Then Exit Do
  26.             Loop
  27.             ActiveSheet.UsedRange.Borders.LineStyle = 1  '对已用区域添加边框
  28.             ActiveSheet.UsedRange.EntireColumn.AutoFit  '自动调整列宽
  29.           End If
  30.     End If
  31.   Next
  32.   
  33.   
  34.   If FindCount > 0 Then
  35.     MsgBox "贺喜，找到" & FindCount & "条记录。", vbOKOnly + vbInformation, "开心"
  36.   Else
  37.     MsgBox "兄弟，对不住啊，一个都没有找到！", vbOKOnly + vbInformation, "痛苦流涕"
  38.   End If

  40. End Sub
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楼
一片叶子
  1. 小鱼
  2. Sub 查找()
  3.   Dim rng As Range, FirstAddress As String, sht As Integer, FindCount As Integer  
  4.    Worksheets.Add before:=Sheets(1)  
  5.     Range("a1:d1") = Array("姓名", "工号", "产品", "数量")
  6.     For sht = 2 To Sheets.Count
  7.      With Sheets(sht)
  8.      Set rng = Sheets(sht).UsedRange.Find("*刀")  
  9.      If Not rng Is Nothing Then  
  10.      FirstAddress = rng.Address  
  11.      Do  
  12.       Set rng = Sheets(sht).UsedRange.Find("*刀", rng, , xlWhole)
  13.       FindCount = FindCount + 1  
  14.       rng.Offset(0, -2).Resize(1, 4).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
  15.       If rng.Address = FirstAddress Then Exit Do
  16.     Loop
  17.     ActiveSheet.UsedRange.Borders.LineStyle = 1  
  18.     ActiveSheet.UsedRange.EntireColumn.AutoFit
  19.    End If
  20.   End With
  21. Next
  22. End Sub
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楼
本人号被盗，
  1. Sub 汇总()
  2. Dim rng As Range, FirstAddress As String, sht As Worksheet, FindCount As Integer  '声明变量
  3. Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "汇总" '新建一个工作表
  4.     Range("a1:d1") = Array("姓名", "工号", "产品", "数量")  '写入列标题
  5.   For i = 1 To Sheets.Count - 1
  6.   Sheets(i).Select
  7.   Set sht = ActiveSheet  '将活动工作表赋予变量
  8.   Set rng = ActiveSheet.UsedRange.Find("*刀")  '在已用区域中查找“*刀”
  9.   If Not rng Is Nothing Then  '如果已经找到
  10.     FirstAddress = rng.Address  '记录下这个单元格的址
  11.    
  12.     Do  '启动循环
  13.       Set rng = sht.UsedRange.Find("*刀", rng, , xlWhole)  '继续查找（上一次找到的单元格后面开始查找)
  14.       FindCount = FindCount + 1  '累加计数器
  15. '找到目标后，将目标所在行的4个单元格一起复制到新工作表中去(从上到下按顺序罗列)
  16.       rng.Offset(0, -2).Resize(1, 4).Copy Worksheets(Sheets.Count).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
  17.       '如果当前找到的目标单元格地址等于第一次记录的单元格地址，那么结束循环
  18.       If rng.Address = FirstAddress Then Exit Do
  19.     Loop
  20.     ActiveSheet.UsedRange.Borders.LineStyle = 1  '对已用区域添加边框
  21.     ActiveSheet.UsedRange.EntireColumn.AutoFit  '自动调整列宽
  22.    
  23.   Else
  24.    
  25.   End If
  26.   Next
  27.   MsgBox "贺喜，找到" & FindCount & "条记录。", vbOKOnly + vbInformation, "开心"
  28. End Sub
22楼
一点点
  1. Sub test() '糊啦啦
  2.     Dim rng As Range, FirstAddress As String, sht As Worksheet, FindCount As Integer  '声明变量
  3.     Dim isheet As Byte

  5.     Worksheets.Add after:=Worksheets(Worksheets.Count)  '新建一个工作表
  6.     Range("a1:d1") = Array("姓名", "工号", "产品", "数量")  '写入列标题

  8.     For isheet = 1 To Sheets.Count - 1
  9.         Sheets(isheet).Select

  11.         Set sht = ActiveSheet  '将活动工作表赋予变量
  12.         Set rng = ActiveSheet.UsedRange.Find("*刀")  '在已用区域中查找"*刀"
  13.         If Not rng Is Nothing Then  '如果已经找到
  14.             FirstAddress = rng.Address  '记录下这个单元格的址

  16.             Do  '启动循环
  17.                 Set rng = sht.UsedRange.Find("*刀", rng, , xlWhole)  '继续查找（上一次找到的单元格后面开始查找)
  18.                 FindCount = FindCount + 1  '累加计数器
  19.                 '找到目标后，将目标所在行的4个单元格一起复制到新工作表中去(从上到下按顺序罗列)
  20.                 rng.Offset(0, -2).Resize(1, 4).Copy Worksheets(Worksheets.Count).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
  21.                 '如果当前找到的目标单元格地址等于第一次记录的单元格地址，那么结束循环
  22.                 If rng.Address = FirstAddress Then Exit Do
  23.             Loop
  24.         End If
  25.     Next isheet
  26. End Sub

在课件案例代码上修改的。达到效果了也应该算数吧
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		 江苏-雪峰

  2. Sub 筛选含刀字的记录()
  3. Dim rng As Range, cell As Range, i As Integer
  4. With Worksheets.Add(after:=Sheets(Sheets.Count))
  5.     .Name = "汇总"
  6.     .Range("A1") = "部门": .Range("B1") = "姓名": .Range("C1") = "工号": .Range("D1") = "生产产品": .Range("E1") = "数量"
  7.     For i = 1 To Sheets.Count - 1
  8.         Set cell = Sheets(i).Cells(Rows.Count, 3).End(xlUp)
  9.         For Each rng In Sheets(i).Range("C2", cell)
  10.             If rng Like "*刀" Then
  11.                 With .Cells(Rows.Count, 1).End(xlUp)
  12.                     .Offset(1, 0) = Sheets(i).Name
  13.                     .Offset(1, 1).Resize(1, 4) = rng.Offset(0, -2).Resize(1, 4).Value
  14.                 End With
  15.             End If
  16.         Next
  17.     Next
  18.     .Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
  19. End With
  20. End Sub

免责声明

有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素， 经与ExcelTip.Net站长Apolloh商议并征得其同意， 现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示， 供有需要的人士查询使用，也慰缅曾经的论坛时代。 所示各个帖子的原作者如对版权有异议， 可与本人沟通提出，或于本站点留言，我们会尽快处理。 在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一

猜您喜欢
评论列表
搜索

鄂ICP备2021011689号-2

powered by emlog pro Theme By 蓝叶

sitemap