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

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

作者：绿色风 分类： 时间：2022-08-18 浏览：144
楼主
罗刚君		 提示：此题目是“VBA入门免费教学群”（群号:30729794）的课后作业
请未参与听课者绕道，谢谢配合。

_____________________________________________________



第23课作业题二.rar


 
请在附件的数据基础上，利用代码实现动画效果。

提示：
实现以上功能需要用到以下知识点，你也可以不用，能实现功能就行了：
1.IsNumeric，用于判断输入的字符是数字还是文本
2.工作表事件，修改单元格时代码可以自动执行
3.Range.Find方法，查找数据
4.条件语句If Then
5.循环语句For Next或者For Each...Next
6.Range.Offset \Range.Resize等属性的应用
7.Range.Copy方法，用于复制单元格或者区域
以上内容全都上过课了，可以轻松实现

_____________________________________________________

第23课作业题二答案.rar
2楼
liaozhifa33		 宁静致远

放置位置：Worksheets("查询界面")代码
总体思路:
1 、当A2单元格改变时执行程序
2、判断A2是数字还是文本
3、循环各表，Range.Find方法，查找数据放到查询表中
4、A2变为空时，清空已经查询的数据
说明:
表中关于find的内容借鉴“客城小生”在
  1. '==========================开始========================
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3. '====================当A2单元格发生改变时候执行==================
  4. If Target.Address = "$A$2" Then
  5. Application.ScreenUpdating = False
  6.     Dim i As Byte, rng As Range, FirstAddress As String, sht As Worksheet, FindCount As Integer '声明变量
  7.     '----------------当A2为数字时候执行-------------------------
  8.     If Len(Range("A2")) <> 0 And IsNumeric(Range("A2")) Then       '判断A2是否为空，以及是否为数字
  9.         Range("B2:D" & Cells.SpecialCells(xlCellTypeLastCell).Row).ClearContents       '清空数据区域的内容
  10.         For i = 1 To Worksheets.Count       '遍历除最后一个表的每个工作表
  11.             Set sht = Worksheets(i)       'sht赋值
  12.             If IsEmpty(sht.UsedRange) Then sht.Delete       '删除空表
  13.             If sht.Name = "查询界面" Then Exit For       '不在查询表中查找
  14.             Set rng = sht.UsedRange.Find(Worksheets("查询界面").Range("A2").Value)       '在已用区域中查找A2的值
  15.             If Not rng Is Nothing Then       '如果已经找到
  16.                 FirstAddress = rng.Address       '记录下这个单元格的址
  17.                 Do       '启动循环
  18.                     Set rng = sht.UsedRange.Find(Worksheets("查询界面").Range("A2").Value, rng, , xlWhole)  '继续查找（上一次找到的单元格后面开始查找)
  19.                     FindCount = FindCount + 1       '累加计数器
  20.                     '找到目标后，将目标所在行的2个单元格一起复制到新工作表中去(从上到下按顺序罗列)
  21.                     rng.Offset(0, -1).Resize(1, 2).Copy Worksheets("查询界面").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
  22.                     '将单元格所在的表名写在班级列
  23.                     Worksheets("查询界面").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = sht.Name
  24.                     '如果当前找到的目标单元格地址等于第一次记录的单元格地址，那么结束循环
  25.                     If rng.Address = FirstAddress Then Exit Do
  26.                 Loop
  27.                 ActiveSheet.UsedRange.Borders.LineStyle = xlNone       '清除边框
  28.                 With Range("A1:A2,B2:D" & Cells(Rows.Count, 4).End(3).Row)
  29.                     .Borders.LineStyle = 1       '对已用区域添加边框
  30.                     .EntireColumn.AutoFit        '自动调整列宽
  31.                     .HorizontalAlignment = xlCenter       '水平居中
  32.                     .VerticalAlignment = xlCenter         '垂直居中
  33.                 End With
  34.             End If
  35.         Next
  36.     Else
  37.     '----------------当A2为文本时候执行-------------------------
  38.         If Len(Range("A2")) <> 0 And IsNumeric(Range("A2")) = False Then       '判断A2是否为空，以及是否为数字
  39.         Range("B2:D" & Cells.SpecialCells(xlCellTypeLastCell).Row).ClearContents       '清空数据区域的内容
  40.         For i = 1 To Worksheets.Count       '遍历除最后一个表的每个工作表
  41.             Set sht = Worksheets(i)       'sht赋值
  42.             If IsEmpty(sht.UsedRange) Then sht.Delete       '删除空表
  43.             If sht.Name = "查询界面" Then Exit For       '不在查询表中查找
  44.             Set rng = sht.UsedRange.Find("*" & Worksheets("查询界面").Range("A2").Value & "*")       '在已用区域中查找A2的值：模糊查询
  45.             If Not rng Is Nothing Then       '如果已经找到
  46.                 FirstAddress = rng.Address       '记录下这个单元格的址
  47.                 Do       '启动循环
  48.                     Set rng = sht.UsedRange.Find("*" & Worksheets("查询界面").Range("A2").Value & "*", rng, , xlPart) '继续查找（上一次找到的单元格后面开始查找)
  49.                     FindCount = FindCount + 1       '累加计数器
  50.                     '找到目标后，将目标所在行的2个单元格一起复制到新工作表中去(从上到下按顺序罗列)
  51.                     rng.Resize(1, 2).Copy Worksheets("查询界面").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
  52.                     '将单元格所在的表名写在班级列
  53.                     Worksheets("查询界面").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = sht.Name
  54.                     '如果当前找到的目标单元格地址等于第一次记录的单元格地址，那么结束循环
  55.                     If rng.Address = FirstAddress Then Exit Do
  56.                 Loop
  57.                 ActiveSheet.UsedRange.Borders.LineStyle = xlNone       '清除边框
  58.                 With Range("A1:A2,B2:D" & Cells(Rows.Count, 4).End(3).Row)
  59.                     .Borders.LineStyle = 1       '对已用区域添加边框
  60.                     .EntireColumn.AutoFit        '自动调整列宽
  61.                     .HorizontalAlignment = xlCenter        '水平居中
  62.                     .VerticalAlignment = xlCenter          '垂直居中
  63.                 End With
  64.             End If
  65.         Next
  66.         Else
  67.     '----------------当A2值被清空时候执行-------------------------
  68.             If Len(Range("A2")) = 0 Or Range("A2") Is Nothing Then      '判断A2是否为空，或者是否为空
  69.             Range("B2:D" & Cells.SpecialCells(xlCellTypeLastCell).Row).ClearContents
  70.             'A2内容被删除时候，清空已有查询内容
  71.                 ActiveSheet.UsedRange.Borders.LineStyle = xlNone        '清除边框
  72.                 With Range("A1:A2,B2:D" & Cells(Rows.Count, 4).End(3).Row)
  73.                     .Borders.LineStyle = 1       '对已用区域添加边框
  74.                     .EntireColumn.AutoFit        '自动调整列宽
  75.                     .HorizontalAlignment = xlCenter       '水平居中
  76.                     .VerticalAlignment = xlCenter         '垂直居中
  77.                 End With
  78.            End If
  79.         End If
  80.     End If
  81. Application.ScreenUpdating = True
  82. End If
  83. End Sub
  84. '==========================结束========================
3楼
ynzsvt		 Private Sub Worksheet_Change(ByVal Target As Range) '在设计好第一行表格的基础上
Dim Rng As Range '声明变量
If Target.Address <> [a2].Address Then Exit Sub '仅对A2单元格输入有效。
Application.EnableEvents = False
Set Rng = [b2]
Rng.Resize(Cells(Rows.Count, "B").End(xlUp).Row, 3).Clear  '原有数据清空，不保留边框格式。为确保空白时不出错，多删除了一行
Application.ScreenUpdating = False
[a2] = Trim([a2])
If IsNumeric([a2]) Then FindA2 (2) Else FindA2 (1) '决定查找数字还是姓名，空白查找成绩空白的
Application.ScreenUpdating = True
Application.EnableEvents = True
[a2].Select
End Sub

Sub FindA2(ByVal i As Integer) '参数是查找的列号
Dim Rng As Range, FirstAddress As String, sht As Worksheet, FindCount As Integer, FindStr$, MsgStr '声明变量
MsgStr = Array("姓名含 ", "成绩=") '不同的未找到显示信息
Select Case i '不同的查找
Case 1
  FindStr = "*" & [a2] & "*"
Case 2
  FindStr = [a2]
Case Else
  Exit Sub
End Select
For Each sht In Worksheets
  With sht
   If .Name <> ActiveSheet.Name Then '查询界面表格不查找
    Set Rng = .Columns(i).Find(FindStr)  '在第i列中查找
    If Not Rng Is Nothing Then  '如果已经找到
     If Rng.Row <= .Cells(Rows.Count, "A").End(xlUp).Row Then
      FirstAddress = Rng.Address  '记录下这个单元格的地址
      Do  '启动循环
       FindCount = FindCount + 1  '累加计数器
       Rng.Offset(0, 1 - i).Resize(1, 2).Copy Cells(Rows.Count, 2).End(xlUp).Offset(1, 1) '整行数据
       ActiveSheet.Hyperlinks.Add Anchor:=Cells(Rows.Count, 2).End(xlUp).Offset(1, 0), Address:="", SubAddress:=.Name & "!" & Rng.Address, _
         TextToDisplay:=.Name   '以链接显示
       Set Rng = .Columns(i).Find(FindStr, Rng, , xlWhole)  '继续查找（上一次找到的单元格后面开始查找)
       If Rng.Row > .Cells(Rows.Count, "A").End(xlUp).Row Then Exit Do '找到超出末尾
      Loop While Rng.Address <> FirstAddress '如果当前找到的目标单元格地址不等于第一次记录的单元格地址，那么继续循环
     End If
    End If
   End If
  End With
Next sht
If FindCount = 0 Then
  MsgBox MsgStr(i - 1) & [a2], , "找不到"
Else
  Set Rng = [b2]
  Rng.Resize(FindCount, 3).Borders.LineStyle = 1 '数据区域加边框
End If
End Sub
4楼
胖头鱼tx		 第一次交作业 没能使用find和resize,有很多缺点，老师见谅。
第23课作业题二.zip
5楼
wangxf9209		 江苏-雪峰
自己觉得有2个遗憾：
   1是没用上IsNumeric；
   2是当同一表中有多个符合条件的记录，第1个总是排在最后复制到查询界面，当然，将19、20、21三行代码复制到DO之前，并且将22行移到18行下面，即可避免。
另外，我觉得罗老师的这种循环查找的方法比用FINDNEXT更简单些。
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. Dim SHT As Worksheet, RNG As Range, I As Integer, N As Integer, K As Boolean
  3. Application.ScreenUpdating = False   '关闭屏幕更新，但是为什么接下来还是能看到逐个粘贴单元格的操作？
  4. If Target.Address = "$A$2" Then     '判断修改的单元格是A2时才执行下面的代码
  5.     With Worksheets("查询界面")     '建立with语句
  6.         .Range("B2:D1000").Clear            '清空显示区域的所有内容
  7.         For I = 1 To Worksheets.Count - 1   '建立循环，从第1个工作表循环到倒数第2个
  8.             Set SHT = Worksheets(I)        '将循环到的工作表赋值给变量
  9.             Set RNG = SHT.Cells.Find(What:=Range("A2").Value, After:=SHT.[A1], LookIn:=xlFormulas, LookAt:= _
  10.                 xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
  11.                 , MatchByte:=False, SearchFormat:=False)       '行查找一遍
  12.             If Not RNG Is Nothing Then            '如果查找到了单元格，就继续执行下面的代码，否则循环下一工作表
  13.                 FirstAddress = RNG.Address    '记下刚才查找到的单元格的地址
  14.                 K = True                      '用变量K记录是否查找到至少一单元格
  15.                 Do                                '建立DO循环
  16.                 Set RNG = SHT.Cells.Find(What:=Range("A2").Value, After:=RNG, LookIn:=xlFormulas, LookAt:= _
  17.                         xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
  18.                         , MatchByte:=False, SearchFormat:=False)   '从上次查找出的单元格往后继续查找
  19.                   N = .Cells(Rows.Count, 2).End(xlUp).Row         '取得查询界面B列最后一个非空单元格的行号
  20.                 .Cells(N + 1, 2) = SHT.Name                       '将查询到的单元格所在工作表名称填入B列
  21.                 SHT.Cells(RNG.Row, 1).Resize(1, 2).Copy .Cells(N + 1, 3)   '将查找到的单元格所在行的A、B列2个单元格复制并粘贴到查询界面
  22.                 If RNG.Address = FirstAddress Then Exit Do        '判断如果此次查找到的单元格地址与前面记录的地址一样，那么结束DO循环
  23.                 Loop
  24.             End If
  25.         Next
  26.         If K Then
  27.             Range("B2", Cells(N + 1, 4)).Borders.LineStyle = 1   '将查找到的记录加上边框，虽然复制过来的可能已经有边框，
  28.         Else
  29.             Range("B2") = "没有查找到符合条件的记录！"   '如果一个符合条件的单元格都没有找到，K的值应该为FALSE，则在B2显示提示文字。
  30.         End If
  31.     End With
  32. End If
  33. Application.ScreenUpdating = True
  34. End Sub
6楼
kcxs		 客城小生的作业，以下代码放在“查询界面”工作表：
  1. Private Sub Worksheet_Change(ByVal Target As Range) '工作表事件
  2. If Target.Address = "$A$2" Then '如果被修改的单元格的址是A2
  3.         '清除上次查询记录
  4.         If Cells(2, 2) <> "" Then
  5.         Range("B2:D2").Select
  6.         Range(Selection, Selection.End(xlDown)).Select
  7.         Selection.Clear
  8.         End If
  9.           '对"B2:D10"区域添加边框
  10.         Range("B2:D10").Select
  11.         Selection.Borders(xlDiagonalDown).LineStyle = xlNone
  12.         Selection.Borders(xlDiagonalUp).LineStyle = xlNone
  13.         With Selection.Borders(xlEdgeLeft)
  14.             .LineStyle = xlContinuous
  15.             .Weight = xlThin
  16.             .ColorIndex = xlAutomatic
  17.         End With
  18.         With Selection.Borders(xlEdgeTop)
  19.             .LineStyle = xlContinuous
  20.             .Weight = xlThin
  21.             .ColorIndex = xlAutomatic
  22.         End With
  23.         With Selection.Borders(xlEdgeBottom)
  24.             .LineStyle = xlContinuous
  25.             .Weight = xlThin
  26.             .ColorIndex = xlAutomatic
  27.         End With
  28.         With Selection.Borders(xlEdgeRight)
  29.             .LineStyle = xlContinuous
  30.             .Weight = xlThin
  31.             .ColorIndex = xlAutomatic
  32.         End With
  33.         With Selection.Borders(xlInsideVertical)
  34.             .LineStyle = xlContinuous
  35.             .Weight = xlThin
  36.             .ColorIndex = xlAutomatic
  37.         End With
  38.         With Selection.Borders(xlInsideHorizontal)
  39.             .LineStyle = xlContinuous
  40.             .Weight = xlThin
  41.             .ColorIndex = xlAutomatic
  42.         End With
  43.         Cells(2, 1).Select '激活查询单元格
  44.     Application.ScreenUpdating = False '关闭屏幕更新，加快代码速度
  45.     Dim Rng As Range, FirstAddress As String, Mc As String, sht As Worksheet, TargetCount As Integer, i As Integer '定义变量
  46.     Mc = Cells(2, 1).Value
  47.     If IsNumeric(Mc) Then
  48.       For i = 1 To Worksheets.Count - 1  '遍历第1到倒数第二个工作表
  49.         Set sht = Worksheets(i)
  50.         Set Rng = sht.Columns(2).Find(Mc)   '在第i个工作表的B列查找与成绩相符的单元格
  51.         If Not Rng Is Nothing Then   '如果已经找到
  52.           FirstAddress = Rng.Address  '记录下它的地址
  53.           Do  '启动循环
  54.             Set Rng = sht.Columns(2).Find(Mc, Rng, , xlWhole) '在rng之后继续查找
  55.             TargetCount = TargetCount + 1  '累加计数器
  56.             '找到后先左移1列，然后重置区域为1行2列，从而得到该行的所有非空单元格，将它们复制到"查询界面"表C列最后一个非空单元格的下一格
  57.             Rng.Offset(0, -1).Resize(1, 2).Copy Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
  58.             Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = sht.Name '对B列赋值为工作表名(班级)
  59.             '如果当前找到的目标单元格地址等于第一次找到的目标单元格地址，那么结束循环
  60.             If Rng.Address = FirstAddress Then Exit Do
  61.           Loop
  62.         End If
  63.       Next  '下一个表
  64.     Else
  65.       For i = 1 To Worksheets.Count - 1  '遍历第1到倒数第二个工作表
  66.         Set sht = Worksheets(i)
  67.         Set Rng = sht.Columns(1).Find(Mc)  '在第i个工作表的A列查找与姓名相符的单元格
  68.         If Not Rng Is Nothing Then   '如果已经找到
  69.           FirstAddress = Rng.Address  '记录下它的地址
  70.           Do  '启动循环
  71.             Set Rng = sht.Columns(1).Find(Mc, Rng, , xlWhole) '在rng之后继续查找
  72.             TargetCount = TargetCount + 1  '累加计数器
  73.             '找到后重置区域为1行2列，从而得到该行的所有非空单元格，将它们复制到"查询界面"表C列最后一个非空单元格的下一格
  74.             Rng.Offset(0, 0).Resize(1, 2).Copy Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
  75.             Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = sht.Name '对B列赋值为工作表名(班级)
  76.             '如果当前找到的目标单元格地址等于第一次找到的目标单元格地址，那么结束循环
  77.             If Rng.Address = FirstAddress Then Exit Do
  78.           Loop
  79.         End If
  80.       Next  '下一个表
  81.     End If
  82.       Application.DisplayAlerts = True   '恢复提示
  83.       Range("a1").CurrentRegion.EntireColumn.AutoFit '自动调整列宽
  84.       MsgBox "找到" & TargetCount & "个目标", vbOKOnly + vbInformation, "友情提示"
  85.     Application.ScreenUpdating = True '恢复闭屏幕更新
  86. End If
  87. End Sub

7楼
一点点
  1. 糊啦啦
  2. Sub zuoy2()    '查找结果不分先后，嘿嘿
  3.     Dim ish As Byte: Dim ifind As Byte: Dim irow As Byte: Dim iend As Byte   '声明行数变量
  4.     Dim rng As Range: Dim ifnd As Range                                      '声明单元格类型变量
  5.     Dim idree As String                                                      '声明字符串类型的变量
  6.     Dim ifc As Byte                                                          '数值变量记录循环次数

  8.     Sheets("查询界面").Range("b2:d10000").ClearContents                       '清空上次查询结果
  9. '========================================================================================================== 以下是代码
  10.     Set rng = Sheets("查询界面").Range("a2")                                   '给单元格变量指定位置

  12.     If IsNumeric(rng.Value) Then                                               '判断单元格内容是否为数值型

  14.         For ish = 1 To Sheets.Count - 1                                        '如果是数值型内容，则循环工作表的个数

  16.             Set ifnd = Sheets(ish).Range("a:b").Find(rng)                      '把符合要求的单元格赋值给单元格变量ifnd

  18.             If Not ifnd Is Nothing Then                                        '如果找到符合条件的单元格,继续执行，否则循环下一个工作表

  20.                 idree = ifnd.Address                                           '把符合要求的单元格地址记录下来

  22.                 Do                                                             'do循环

  24.                     Set ifnd = Sheets(ish).Range("a:b").Find(rng, ifnd, , xlWhole) '继续往下查找

  26.                     ifc = ifc + 1                                                '记录循环次数

  28.                                                                                  '把当前循环的工作表名放入查询界面的B列最后一个非空单元格里
  29.                     Sheets("查询界面").Range("b" & Cells(Rows.Count, 3).End(3).Row + 1) = Sheets(ish).Name

  31.                                                                                  '把找到符合要求的行内容复制到查询界面CD列的最后一个非空单元格里
  32.                     ifnd.Offset(0, -1).Resize(1, 2).Copy Sheets("查询界面").Range("c" & Cells(Rows.Count, 3).End(3).Row + 1)

  34.                     If ifnd.Address = idree Then Exit Do                         '判断当前找到的目标单元格地址是否等于第一次记录的单元格地址，如果是就结束循环，否则继续查找

  36.                 Loop                                                              'do循环结束语

  38.             End If

  40.         Next ish

  42.     Else

  44.         For ish = 1 To Sheets.Count - 1                                        '如果是数值型内容，则循环工作表的个数

  46.             Set ifnd = Sheets(ish).Range("a:b").Find("*" & rng & "*")           '把符合要求的单元格赋值给单元格变量ifnd

  48.             If Not ifnd Is Nothing Then                                        '如果找到符合条件的单元格,继续执行，否则循环下一个工作表

  50.                 idree = ifnd.Address                                           '把符合要求的单元格地址记录下来
  51.                 Debug.Print idree

  53.                 Do                                                             'do循环

  55.                     Set ifnd = Sheets(ish).Range("a:b").Find("*" & rng & "*", ifnd, , xlWhole) '继续往下查找

  57.                     ifc = ifc + 1                                                '记录循环次数

  59.                                                                                   '把当前循环的工作表名放入查询界面的B列最后一个非空单元格里
  60.                     Sheets("查询界面").Range("b" & Cells(Rows.Count, 3).End(3).Row + 1) = Sheets(ish).Name

  62.                                                                                   '把找到符合要求的行内容复制到查询界面CD列的最后一个非空单元格里
  63.                     ifnd.Resize(1, 2).Copy Sheets("查询界面").Range("c" & Cells(Rows.Count, 3).End(3).Row + 1)

  65.                     If ifnd.Address = idree Then Exit Do                         '判断当前找到的目标单元格地址是否等于第一次记录的单元格地址，如果是就结束循环，否则继续查找

  67.                 Loop                                                              'do循环结束语

  69.             End If

  71.         Next ish

  73.     End If

  75. End Sub
这次全注释了好认真哦
8楼
lfwxszw		 群名片：简单
在查询界面的worksheet_change里录入以下代码

Private Sub Worksheet_Change(ByVal Target As Range)
'worksheet_change事件的TARGET是 失去焦点前的单元格
'焦点失去前如果单元格地址是A2 那么
If Target.Address = Range("a2").Address Then
Call 多表多内容查询
End If
End Sub
  1. Sub 多表多内容查询()
  2. '=================================================
  3. ' For Each .. Next
  4. '此方法，不用考虑  查询界面，在工作簿中的位置,不用考虑要查找的数据在第几列
  5. '=============================================
  6. '关闭屏幕更新
  7. Application.ScreenUpdating = False
  8. '容错
  9. On Error Resume Next
  10. '定义变量
  11. Dim rng As Range, firstaddress As String, sht As Worksheet, hd As Range, tj
  12. Set hd = Worksheets("查询界面").UsedRange
  13. '清除B2开始到已用区域最大行 列的值
  14. Range(Cells(2, 2), Cells(hd.Rows.Count, hd.Columns.Count)).Clear
  15. '变量条件(tj)赋值
  16. tj = Cells(2, 1)
  17.     For Each sht In Worksheets
  18.          '如果表名不是 查询界面 那么就查找
  19.         If sht.Name <> "查询界面" Then
  20.               '查询 tj 完全匹配，按行查找
  21.               Set rng = sht.UsedRange.Find(tj, , , xlWhole, xlByRows)
  22.                  '如果找到
  23.                  If Not rng Is Nothing Then
  24.                  '赋值给firstaddress
  25.                  firstaddress = rng.Address
  26.                  Do
  27.                  '在firstaddress后继续查找
  28.                  Set rng = sht.UsedRange.Find(tj, rng, , xlWhole, xlByRows)
  29.                  'B列非空下一单元格，为sht.name名，且设置边框
  30.                  Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = sht.Name
  31.                  Cells(Rows.Count, 2).End(xlUp).Borders.LineStyle = xlContinuous
  32.                  '目标偏移 －行号+1，重置（1行，当前区域列数和 列） 复制到 第3列非空下一格
  33.                  rng.Offset(0, -rng.Column + 1).Resize(1, rng.CurrentRegion.Columns.Count).Copy Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
  34.                  '直到找到地址与第一次相同停止
  35.                  Loop Until rng.Address = firstaddress
  36.                  End If
  37.         End If
  38.     Next '下一个表
  39.     '开启屏幕更新，已用区域自动列宽
  40.     Application.ScreenUpdating = True
  41.     hd.EntireColumn.AutoFit
  42. End Sub
9楼
大猫
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.     Dim rg As Range, rgg As Range, i%, X%, a%, rg2 As Range
  3.    If Target = Range("a2") Then '点击A2时起动事件
  4.     Range("b2:d10").ClearContents
  5.     For i = 1 To 5
  6.         X = X + 1
  7.         If IsNumeric(Range("a2")) Then    '判别是否是文本
  8.             Set rgg = Sheets(X).Range("b2:b11")    '数值
  9.             For Each rg In rgg
  10.                 If rg = Sheets(6).Range("a2") Then
  11.                     Sheets(6).Range("d65536").End(xlUp).Offset(1, 0) = rg
  12.                     Sheets(6).Range("C65536").End(xlUp).Offset(1, 0) = rg.Offset(0, -1)
  13.                     Sheets(6).Range("b65536").End(xlUp).Offset(1, 0) = Sheets(X).Name
  14.                 End If
  15.             Next
  16.         Else
  17.             Set rgg = Sheets(X).Range("a2:a11")    '文本
  18.             For Each rg In rgg
  19.                 Set rg2 = rg.Find(Sheets(6).Range("a2") & "*", rg) '按姓模糊查找
  20.                 If Not rg2 Is Nothing Then
  21.                     Sheets(6).Range("c65536").End(xlUp).Offset(1, 0) = rg
  22.                     Sheets(6).Range("d65536").End(xlUp).Offset(1, 0) = rg.Offset(0, 1)
  23.                     Sheets(6).Range("b65536").End(xlUp).Offset(1, 0) = Sheets(X).Name
  24.                 End If
  25.             Next
  26.         End If
  27.     Next
  28. End If
  29. End Sub
10楼
冰淇林的冬天		 群号:30729794
冰激凌的冬天
第23课作业题二.rar
11楼
paoge		 骑着钓箱看世界

Private Sub Worksheet_Change(ByVal target As Range)
On Error Resume Next                                      '有错误继续执行下一步
Dim 结果区域 As Range, 首个对象 As Range, 下个对象 As Range, i As Byte, docount, ofset As Byte
  '将变量赋值为target所在列右边的已用区域
Set 结果区域 = Intersect(Worksheets("查询界面").UsedRange.Offset(0, 1), Worksheets("查询界面").UsedRange.Offset(0, 0))
   Application.EnableEvents = False
     If target.Address = "$A$2" Then                     '限制触发事件为a2单元格且值的类型为数值
     结果区域.Offset(1, 0).ClearContents                '清空区域中的已有数据
     If VBA.IsNumeric(target) Then                     '判断是成绩查询还是姓名查询
       ofset = 0                                    '按成绩查询时将变量ofset赋值为“0 ”
     Else
           ofset = 1                                    '按姓名查询时将变量ofset赋值为“1 ”
     End If
        For i = 1 To Worksheets.Count - 1         '遍历除最后一个工作表的所有工作表
             '开始查找，查找的对象是target的值，匹配方式是完全匹配
        Set 首个对象 = Worksheets(i).UsedRange.Find(target, , xlValues, xlWhole)
             Set 下个对象 = 首个对象                         '将“下个对象”变量赋值为第一次找到的对象
            If Not 首个对象 Is Nothing Then                                               '如果找到对象
              With 结果区域.Cells(Rows.Count, 3).End(xlUp)             '工作表“查询界面”D列最后一个非空单元格
                     '把找到的第一个对象写到D列最后一个非空单元格下的第一个空单元格
                   .Offset(1, 0) = 首个对象.Offset(0, ofset).Value
                           'C列最后个非空单元格中填上找到对象所对应的姓名
                   .Offset(1, -1) = 首个对象.Offset(0, ofset - 1).Value
                           'B列最后个非空单元格中填上找到对象所对应的工作表名
                   .Offset(1, -2) = Worksheets(i).Name
                      End With
                      Do
                          docount = docount + 1                                             '循环次数
                             '查找下一个，从上次查找到的目标之后开始查找
                Set 下个对象 = Worksheets(i).UsedRange.FindNext(下个对象)
                          If 下个对象.Address = 首个对象.Address Then     '如果找到的下一个目标和第一次找到的地址一样
                    Exit Do                                                        '退出循环
                Else
                          With 结果区域.Cells(Rows.Count, 3).End(xlUp)      '工作表“查询界面”D列最后一个非空单元格
                         '把找到的对象写到D列最后一个非空单元格下的第一个空单元格
                     .Offset(1, 0) = 下个对象.Offset(0, ofset).Value
                                       'C列最后个非空单元格中填上找到对象所对应的姓名
                     .Offset(1, -1) = 下个对象.Offset(0, ofset - 1).Value
                                       'B列最后个非空单元格中填上找到对象所对应的工作表名
                     .Offset(1, -2) = Worksheets(i).Name
                          End With
                        End If
                    Loop
            End If
        Next i
    End If
  Application.EnableEvents = True
End Sub
12楼
′鈊、		 Private Sub Worksheet_Change(ByVal Target As Range) '工作表事件<修改单元格的值运行代码>
   Application.ScreenUpdating = False '关闭刷新
      Dim rng As Range, FirstAddress As String, sht As Integer, cxtj As Range, cxjm As Worksheet '声明变量
With Worksheets("查询界面")
         Set cxtj = .Range("a2") '将名为"查询界面"工作表中的单元格A2赋值给变量cxtj
   If Target.Address = "$A$2" Then '修改单元格A2的值就运行以下代码
       Intersect(.UsedRange.Offset(0, 0), .UsedRange.Offset(1, 1)).Clear '清除
      For sht = 1 To Worksheets.Count '将活动工作表赋予给变量sht
         If Worksheets(sht).Name = "查询界面" Then GoTo 下一个 '如果工作表名是"查询界面"就跳到下一个表继续查询
        Set rng = Worksheets(sht).UsedRange.Find(cxtj)  '根据工作表"查询界面"中查询条件在已用区域中查找
        If Not rng Is Nothing Then  '如果已经找到
           FirstAddress = rng.Address  '记录下这个单元格的址
             Do  '启动循环
               Set rng = Worksheets(sht).UsedRange.Find(cxtj, rng, , xlWhole)  '继续查找（上一次找到的单元格后面开始查找)
              If IsNumeric(cxtj) Then '如果赋予变量的值是数字
  '找到目标后，将目标所在行的2个单元格一起复制到"查询界面"工作表中去(从上到下按顺序罗列)
                   rng.Offset(0, -1).Resize(1, 2).Copy .Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
                  .Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = Worksheets(sht).Name
              Else '否则（如果是文本）
                   rng.Resize(1, 2).Copy .Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
                  .Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = Worksheets(sht).Name
              End If
      '如果当前找到的目标单元格地址等于第一次记录的单元格地址，那么结束循环
                 If rng.Address = FirstAddress Then Exit Do
            Loop '结束循环
        End If
下一个: Next sht '继续下一个工作表
    End If
       Intersect(.UsedRange.Offset(1, 1), .UsedRange).Borders.LineStyle = 1 '对已用区域添加边框
End With
     Application.ScreenUpdating = True '关闭刷新
End Sub
13楼
杭州小菜02		 Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next  '遇到错误继续执行
Application.ScreenUpdating = False '禁止屏幕更新
Application.EnableEvents = False  '禁止启用事件
With ActiveSheet '设置第一个with块，简化引用
.Range("a1:d1") = [{"查询条件","班级","姓名","成绩"}] '设置列标题
Worksheets("一班").Range("a1:B1").Copy '复制一班a1:b1
.Range("a1:d1").PasteSpecial xlPasteFormats '粘贴一班a1:b1的格式
Application.EnableEvents = True '启用事件
Dim RNGG As Range '声明变量
If Target.Address = Range("a2").Address Then   '如果要改变的单元格地址是A2才继续代码，否则不需要执行此代码
Set RNGG = Target   '用变量代替单元格对象，用于提速
RNGG.Borders.LineStyle = 1 '设置查询条件的边框
RNGG.Comment.Delete '删除批注
RNGG.AddComment "在此输入查询条件" & Chr(10) & "可以输入姓名或者成绩用来查询"
Application.ScreenUpdating = False '禁止屏幕刷新
If Cells(Rows.Count, 4).End(xlUp).Address <> "$D$1" Then '先进行判断是否有查找到的信息
    Range("b2:d" & Cells(Rows.Count, 4).End(xlUp).Row).Clear '清除之前查找到的信息
End If
Dim sht As Worksheet, Rng As Range, i As Integer
For Each sht In Worksheets   '遍历所有工作表
    If sht.Name <> "查询界面" Then    '如果不等于查询界面工作表
        For Each Rng In Intersect(sht.Range("a:b"), sht.UsedRange)    '遍历每个表的b列和已用区域交集的单元格
                If RNGG.Value = Rng.Value Then    '如果要查找的值=变量rng的值
                    If IsNumeric(RNGG.Value) Then
                        RNGG.Offset(i, 1) = sht.Name    '将找到的工作表名赋值给B列
                        RNGG.Offset(i, 2) = Rng.Offset(0, -1)   '将找到的姓名赋值给C列
                        RNGG.Offset(i, 3) = Rng.Value   '将找到的成绩赋值给D列
                    Else
                        RNGG.Offset(i, 1) = sht.Name    '将找到的工作表名赋值给B列
                        RNGG.Offset(i, 2) = Rng   '将找到的姓名赋值给C列
                        RNGG.Offset(i, 3) = Rng.Offset(0, 1)  '将找到的成绩赋值给D列
                    End If
                    i = i + 1   '计数器i+1用来设置下次查找到的信息填充地址的偏移量
                End If   '结束第三层if
        Next   '内层循环
    End If  '结束第二层if
Next  '外层循环
End If  '结束第一层if
.UsedRange.Columns("a:d").EntireColumn.AutoFit '设置已用区域的a:d列自动列宽
.UsedRange.Columns("b:d").Borders.LineStyle = 1 '设置已用区域的b:d列边框
End With '结束第一层with块
Application.ScreenUpdating = True '恢复屏幕刷新
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'方法2，自动筛选法
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" Then  '如果更改的单元格地址是A2,注意此处是字符串的比较
Application.ScreenUpdating = False '禁止屏幕刷新
   Dim Rng As Range, i As Integer, sht As Worksheet
   With Worksheets("查询界面") '简化引用和提速
   Set Rng = .Range("A2") '用变量代替单元格对象，提示速度
If Len(.Range("A2")) <> 0 And IsNumeric(.Range("A2")) Then '如果查询条件A2单元格有内容，并且是数字的话，则继续下面的代码，否则执行else后面代码
    '如果B列的最后非空单元格的行数大于1（即除了标题外还有其他数据，则对（查询界面工作表的B2:已用区域的最后一个单元格的区域）清除所有
    If .Cells(Rows.Count, "b").End(xlUp).Row > 1 Then .Range(.Range("B2"), .UsedRange.SpecialCells(xlCellTypeLastCell)).Clear
        For Each sht In Worksheets '遍历此工作薄的工作表
            If sht.Name <> "查询界面" Then '如果工作表名不等于查询界面，则继续下面的代码
             If IsEmpty(sht.UsedRange) Then sht.Delete '如果工作表未初始化则删除这张工作表
             sht.AutoFilterMode = False   '取消表格的筛选状态
             sht.UsedRange.AutoFilter '插入筛选
             '设置筛选条件，执行筛选
             sht.Range("a1:b" & sht.Cells(Rows.Count, 2).End(xlUp).Row).AutoFilter Field:=2, Criteria1:=Rng.Value
                 '如果筛选后的区域偏移一行的区域中第一个单元格不等于查询条件，就跳出复制代码的过程
                 If sht.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible)(2) <> Rng.Value Then GoTo 跳
                 '将筛选后的区域的可见单元格偏移一行的区域复制到查询界面工作表，注意查询工作表的粘贴区域
                 sht.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy .Cells(.Cells(Rows.Count, 3).End(xlUp).Row + 1, "c")
                 Set rngg = sht.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible) '用变量来记录筛选后的区域
                 i = rngg.Count / 2 - 1 '用i来记录筛选的结果的数量-1，因为有2列没找到一条记录，count就是2，而且筛选前的区域偏移了一行
                '将对应的工作表名填写到B列，注意B列的重置区域
                .Cells(.Cells(Rows.Count, 2).End(xlUp).Row + 1, "b").Resize(i, 1) = rngg.Parent.Name
跳: '标签，用来跳出复制粘贴的代码
                sht.AutoFilterMode = False     '取消表格的筛选状态
            End If '结束第二个if
        Next '继续循环
Else '否则，意思是查询条件不是成绩，可能是姓名
       .Range(.Range("B2"), .UsedRange.SpecialCells(xlCellTypeLastCell)).Clear '对（查询界面工作表的B2:已用区域的最后一个单元格的区域）清除所有
        For Each sht In Worksheets '遍历此工作薄的工作表
            If sht.Name <> "查询界面" Then '如果工作表名不等于查询界面，则继续下面的代码
                If IsEmpty(sht.UsedRange) Then sht.Delete '如果工作表未初始化则删除这张工作表
                sht.AutoFilterMode = False    '取消表格的筛选状态
                sht.UsedRange.AutoFilter '插入筛选
                '设置筛选条件，执行筛选，用成绩以外的搜索条件可以模糊筛选
                sht.Range("a1:b" & sht.Cells(Rows.Count, 2).End(xlUp).Row).AutoFilter Field:=1, Criteria1:="=*" & Rng.Value & "*"
                    '如果筛选后的区域偏移一行的区域中第一个单元格不包含筛选条件的数据，就跳出复制代码的过程
                    If InStr(sht.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1), Rng.Value) < 1 Then GoTo 跑
                        '将筛选后的区域的可见单元格偏移一行的区域复制到查询界面工作表，注意查询工作表的粘贴区域
                        sht.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy .Cells(.Cells(Rows.Count, 3).End(xlUp).Row + 1, "c")
                        Set rngg = sht.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible) '用变量来记录筛选后的区域
                        i = rngg.Count / 2 - 1 '用i来记录筛选的结果的数量-1，因为有2列没找到一条记录，count就是2，而且筛选前的区域偏移了一行
                        '将对应的工作表名填写到B列，注意B列的重置区域
                        .Cells(.Cells(Rows.Count, 2).End(xlUp).Row + 1, "b").Resize(i, 1) = rngg.Parent.Name
跑:
                    sht.AutoFilterMode = False '取消表格的筛选状态
                End If '结束else中的第一个if
        Next '继续循环
End If '结束第二层if
.Range("b1:d" & Cells(Rows.Count, 4).End(xlUp).Row).Borders.LineStyle = xlContinuous '给查询到的数据添加边框
.Range("A1:a2").Borders.LineStyle = xlContinuous '给条件区域设置边框
Application.ScreenUpdating = True '恢复屏幕刷新
End With '结束with块
End If '结束第一层IF
End Sub

14楼
无言的人		 无言
很久没做了，报道下
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     With Target
  3.         Rem 改变单元格 非A2 或 为空 时退出过程
  4.         If .Address(0, 0) <> "A2" Then End
  5.         If .Value = "" Then End
  6.         Dim BLo As Boolean, Sht As Worksheet, RRow As Integer, RCol As Byte
  7.         Dim CXrow As Integer, ShRng As Range, TRng As Range, FRng As Range
  8.         Rem CXrow 确认查询表中已使用行数，并从B2开始清空内容
  9.         CXrow = Sheets("查询界面").Range("B" & Cells.Rows.Count).End(xlUp).Row
  10.         Rem 关闭屏幕刷新
  11.         Application.ScreenUpdating = False
  12.         Rem 关闭响应时间，防止重复激活事件
  13.         Application.EnableEvents = False
  14.         Rem 清除区域所有内容，+1 是为了防止清空标题行
  15.         Sheets("查询界面").Range("B2:D" & CXrow + 1).Clear
  16.         Rem 定义变量Blo 判断是否为数字
  17.         BLo = IsNumeric(.Value)
  18.         Rem 根据Blo 判断
  19.         Dim CxMs As Boolean, Ms As Integer  '确认文字类型的查询模式为精确或模糊
  20.         If BLo = False Then
  21.             CxMs = Application.InputBox("请输入 0 或 非0 数字" & vbCr & _
  22.                 "0 为文字精确查找" & vbCr & "非 0 为文字模糊查找", "查找模式提示", 0, , , , , 1)
  23.             Select Case CxMs
  24.                 Case 0
  25.                     Ms = xlWhole
  26.                 Case Else
  27.                     Ms = xlPart
  28.             End Select
  29.         End If
  30.         Rem For 循环语句执行判断是否满足查询条件
  31.         For Each Sht In Worksheets
  32.             If Sht.Name <> "查询界面" Then
  33.                 Rem 获取非查询界面工作表中的区域最大使用行列号
  34.                 RRow = Application.Intersect(Sht.UsedRange, Sht.Range("A1").CurrentRegion).Rows.Count
  35.                 RCol = Application.Intersect(Sht.UsedRange, Sht.Range("A1").CurrentRegion).Columns.Count
  36.                 Rem 使用Select Case 判断语句执行
  37.                 Select Case BLo
  38.                     Case True
  39.                         Rem 如果数字 小于0 或 大于100 则均退出
  40.                         If .Value < 0 Or .Value > 100 Then End
  41.                         Rem 赋值各工作表查询区域
  42.                         Set ShRng = Sht.Range("B2").Resize(RRow - 1)
  43.                         Rem 区域中循环查找某值
  44.                         For Each TRng In ShRng
  45.                             Rem 获取查询界面表中最大使用行
  46.                             CXrow = Sheets("查询界面").Range("B" & Cells.Rows.Count).End(xlUp).Row
  47.                             Rem 通过FRng中能否找到需要的值，没有值则为Nothing
  48.                             Set FRng = TRng.Find(What:=.Value, After:=TRng, LookIn:=xlValues, _
  49.                                 LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
  50.                             Rem 如果查找到了则将工作表名称及相应的行范围复制到查询界面表中
  51.                             If Not (FRng Is Nothing) Then
  52.                                Sheets("查询界面").Cells(CXrow + 1, 2) = Sht.Name
  53.                                TRng.Offset(ColumnOffset:=-1).Resize(1, 2).Copy Sheets("查询界面").Cells(CXrow + 1, 3)
  54.                             End If
  55.                         Next TRng
  56.                         Rem 释放区域对象
  57.                         Set ShRng = Nothing
  58.                     Case Else
  59.                         Rem 非数字时，查询的思路同数字基本类似，不在重复
  60.                         Set ShRng = Sht.Range("A2").Resize(RRow - 1)
  61.                         For Each TRng In ShRng
  62.                             CXrow = Sheets("查询界面").Range("B" & Cells.Rows.Count).End(xlUp).Row
  63.                             Set FRng = TRng.Find(What:=.Value, After:=TRng, LookIn:=xlValues, _
  64.                                 LookAt:=Ms, SearchOrder:=xlByRows, SearchDirection:=xlNext)
  65.                             If Not (FRng Is Nothing) Then
  66.                                Sheets("查询界面").Cells(CXrow + 1, 2) = Sht.Name
  67.                                TRng.Resize(1, 2).Copy Sheets("查询界面").Cells(CXrow + 1, 3)
  68.                             End If
  69.                         Next TRng
  70.                         Set ShRng = Nothing
  71.                 End Select
  72.              End If
  73.         Next Sht
  74.     End With
  75.     Rem 区域方位边框实线
  76.     Sheets("查询界面").Range("B2:D" & CXrow).Borders.LineStyle = xlContinuous
  77.     Application.EnableEvents = True
  78.     Application.ScreenUpdating = True
  79. End Sub
15楼
wendel		 无心手语
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     If Target.Address = "$A$2" Then '查询界面中只有单元格A2值发生变化才启动查询过程
  3.         Call MainQuery  '调用模块1中的查询过程
  4.     End If
  5. End Sub

  7. Dim What, Sht As Worksheet, MainSht As Worksheet, Rng As Range
  8. Dim FirstAddress As String
  9. Dim Shift As Integer, FindCounter As Integer

  11. Sub MainQuery()
  12.     Application.ScreenUpdating = False
  13.     Set MainSht = Sheets("查询界面")
  14.     What = MainSht.Range("A2")
  15.     With MainSht.UsedRange '清理标题和查询条件之外的单元格区域
  16.         .Offset(1, 1).Clear
  17.         .Offset(2, 0).Clear
  18.     End With
  19.     If Len(What) = 0 Then '如果查询条件为空，提示并退出
  20.         MsgBox "查询条件不能为空！"
  21.         Exit Sub
  22.     End If
  23.     If VBA.IsNumeric(What) Then '根据单元格值，判断成绩查询还是姓名查询，姓名支持部分字符查询
  24.         lookat = xlWhole '完全匹配
  25.         Shift = -1
  26.     Else
  27.         What = "*" & What & "*" '文字可以部分符合条件即可
  28.         lookat = xlPart '部分匹配
  29.         Shift = 0
  30.     End If
  31.     MyQuery What, lookat
  32.     ' 给查找到的记录添加边框
  33.     Intersect(MainSht.UsedRange.Offset(1, 1), MainSht.UsedRange).Borders.LineStyle = xlContinuous
  34.     '根据查找的记录，提示符合条件记录数多少进行提示
  35.     If FindCounter <> 0 Then
  36.         MsgBox "共找到" & FindCounter & "条记录！", vbOKOnly + vbInformation
  37.     Else
  38.         MsgBox "没有符合条件的记录！", vbOKOnly + vbInformation
  39.     End If
  40.     FindCounter = 0 '计数器清零
  41.     Application.ScreenUpdating = True
  42. End Sub

  44. Sub MyQuery(ByVal What, ByVal lookat)
  45.     For Each Sht In Worksheets '遍历工作簿内所有工作表
  46.         If Sht.Name <> "查询界面" Then '"查询界面"工作表非源数据表，不参与处理
  47.             Set Rng = Sht.UsedRange.Find(What:=What, lookat:=lookat) '参数由上一个过程传递而来
  48.             If Not Rng Is Nothing Then
  49.                 FirstAddress = Rng.Address  '记录第一次找到位置地址
  50.                 Do
  51.                     Set Rng = Sht.UsedRange.Find(What:=What, After:=Rng, lookat:=lookat) '从上一次查找位置之后开始查找
  52.                     FindCounter = FindCounter + 1
  53.                     MainSht.Range("b" & FindCounter + 1) = Sht.Name '记录班级
  54.                     Rng.Offset(0, Shift).Resize(1, 2).Copy MainSht.Range("C" & FindCounter + 1) '名字和成绩所在列不同，由shift来控制offset的参数
  55.                     If Rng.Address = FirstAddress Then Exit Do '地址重复表示，开始第二轮查找，故退出
  56.                 Loop
  57.             End If
  58.         End If
  59.     Next
  60. End Sub

第23课作业题二by无心手语 .rar
16楼
xj_lucky		 Private Sub worksheet_change(ByVal target As Range)
    Dim i As Byte, sht As Worksheet, rng As Range, FirstAddress As String, FindCount As Integer, x As Integer
    Set target = Range("a2")
     If IsNumeric(target) = True Then
       x = -1
       Else
       x = 0
    End If
     For i = 1 To Worksheets.Count - 1
        Set sht = Worksheets(i)  '将活动工作表赋予变量
        
        Set rng = sht.UsedRange.Find(target)   '在已用区域中查找数字或文本
        If Not rng Is Nothing Then  '如果已经找到
            FirstAddress = rng.Address  '记录下这个单元格的址

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

        End If
      
        
    Next
   
End Sub


'代码报错方法find不能使用对象range，请罗老师指导一下，谢谢！
17楼
静思雨		 帮网友 ambitious_lee  交的
  1. Sub auto_open()
  2. Call 调用
  3. End Sub
  4. Sub 调用()
  5. Application.OnKey "~", "text1" '用ENTER键调用过程
  6. End Sub
  7. Sub text1()
  8. t = Timer
  9. Application.ScreenUpdating = False '关闭屏幕更新
  10. Application.DisplayAlerts = False '关闭程序报警
  11. Dim sheetnum As Integer '定义变量赋值工作表的数量，以及一个数组
  12. sheetnum = Sheets.Count '将工作表数量赋值给变量，方便后面调用
  13. For i = 1 To sheetnum '判断是否存在查询界面工作表
  14.     If Worksheets(i).Name = "查询界面" Then GoTo 不要新建工作表
  15. Next
  16. Worksheets.Add after:=Worksheets(Worksheets.Count) '如果不存在新建
  17. ActiveSheet.Name = "查询界面" '给新建工作表命名
  18. Range("a2") = "在此输入查找内容" '给录入员提示在A2输入查找内容
  19. 不要新建工作表: Worksheets("查询界面").Activate '如果存在工作表查找界面
  20. Set irng = Range("a1:d2") '给rng变量赋值
  21. Worksheets("一班").Range("a1:b2").Copy '赋值工作表的格式
  22. irng.PasteSpecial Paste:=xlFormats '粘贴格式
  23. Range("a1:d1") = Array("查询条件", "班级", "姓名", "成绩") '给单元格赋值
  24. If Range("a2") = "" Then Exit Sub '如果A2为空则退出过程
  25. Dim irow As Integer '定义变量赋值工作表数量给sheetnum,赋值已用区域行给irow
  26. sheetnum = Worksheets.Count - 1 '将循环的工作表的数量赋值给sheetnum
  27. inum = 1 '排除第一行
  28. Range("b2:d" & Cells(Rows.Count, 4).End(3).Row + 1).ClearContents '清除单元格内容
  29. If IsNumeric(Cells(2, 1)) Then '先判断输入的是文本还是数值,这样减少循环
  30.     For i = 1 To sheetnum '如果是数值循环每个表格的B列
  31.         For irow = 1 To Worksheets(i).Cells(Rows.Count, 2).End(3).Row '行循环
  32.             If Worksheets(i).Cells(irow, 2) Like "*" & Cells(2, 1) & "*" Then '与输入值比较
  33.             inum = inum + 1
  34.             Cells(inum, 2) = Worksheets(i).Name '符合的将值填入相应的列
  35.             Cells(inum, 3) = Worksheets(i).Cells(irow, 1)
  36.             Cells(inum, 4) = Worksheets(i).Cells(irow, 2)
  37.             End If
  38.         Next
  39.     Next
  40. Else
  41.     For i = 1 To sheetnum '循环每个表格的A列
  42.         For irow = 1 To Worksheets(i).Cells(Rows.Count, 1).End(3).Row '行循环
  43.             If Worksheets(i).Cells(irow, 1) Like "*" & Cells(2, 1) & "*" Then '与输入值比较
  44.             inum = inum + 1
  45.             Cells(inum, 2) = Worksheets(i).Name '符合的值填入相应的列
  46.             Cells(inum, 3) = Worksheets(i).Cells(irow, 1)
  47.             Cells(inum, 4) = Worksheets(i).Cells(irow, 2)
  48.             End If
  49.         Next
  50.     Next
  51. End If
  52. Application.ScreenUpdating = True '开启屏幕更新
  53. Application.DisplayAlerts = True
  54. Range(Cells(2, 2), Cells(Rows.Count, 4).End(3)).Borders.LineStyle = xlContinuous '给已用区域添加边框
  55. MsgBox "用时：" & Timer - t
  56. End Sub
18楼
静思雨		 事件代码：
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     If Target.Address = "$A$2" Then '如果目标单元格是“A2”
  3.         If Len(Target.Value) > 0 Then '如果目标单元格不为空
  4.             Query (Target.Value) '将目标单元格的值当作QUERY过程的参数给QUERY过程
  5.         End If
  6.     End If
  7. End Sub
模块代码：
  1. Sub Query(FStr As String)
  2.     Dim Sht As Worksheet '定义一个工作表变量
  3.     Dim sFirstaddress As String '定义一个DO循环跳出变量
  4.     Dim rng As Range '定义range变量
  5.     Dim lastrow As Integer '定义变量
  6.     Application.ScreenUpdating = False '关闭屏幕更新
  7.     With Sheets("查询界面")
  8.         .Range("b2:d" & Cells(Rows.Count, 4).End(xlUp).Row + 1).Clear '清楚表格里的内容
  9.     End With
  10.     lastrow = 2 '给变量赋值
  11.     For Each Sht In Worksheets '循环工作薄
  12.         If Sht.Name <> "查询界面" Then
  13.             Set rng = Sht.Cells.Find(What:=FStr, after:=Sht.Cells(Rows.Count, 1), _
  14.             LookIn:=xlValues, lookat:=xlPart) '模糊查找与FSTR参数相符项
  15.             If Not rng Is Nothing Then
  16.                 sFirstaddress = rng.Address '将第一个找到的相符项的地址赋给变量
  17.                 Do
  18.                    Sheets("查询界面").Cells(lastrow, 2) = Sht.Name '将符合项的值赋给单元格
  19.                    Sheets("查询界面").Cells(lastrow, 3) = Sht.Cells(rng.Row, 1)
  20.                    Sheets("查询界面").Cells(lastrow, 4) = Sht.Cells(rng.Row, 2)
  21.                    Set rng = Sht.Cells.FindNext(rng) '查找下一个符合项
  22.                     lastrow = lastrow + 1 '行号+1
  23.                 Loop While Not rng Is Nothing And sFirstaddress <> rng.Address
  24.                 Range("b2:d" & Cells(Rows.Count, 4).End(xlUp).Row).Borders.LineStyle = xlContinuous '给单元格增加线框
  25.             End If
  26.         End If
  27.     Next
  28.     Application.ScreenUpdating = True '打开屏幕更新
  29. End Sub
19楼
本人号被盗，		 河南蓝天，罗总，辛苦很长时间，尽管没那么完美，自己还是觉得很开心。在罗总的指导下能走这么远。另代码里附带有个问题，请教。谢谢罗总
  1. Sub Worksheet_Change(ByVal Target As Range)
  2.     If Intersect(Target, Range("a2")) Is Nothing Then Exit Sub '如果不是点击A2单元格，退出sub
  3.    Range(Cells(2, 2), Cells(Rows.Count, 4).End(xlUp)).Clear '清除上次查询结果
  4.    
  5.    

  7. Range("A1:d1") = Array("查询条件", "班级", "姓名", "成绩") '生成标题行
  8.     Dim i As Byte, sht As Worksheet, rng As Range, rng1 As Range, FirstAddress As String, FindCount As Integer, x As Integer '定义变量
  9.     If IsNumeric(Target) = True Then '利用判断，设置变量，吸取别人精华
  10.        x = -1
  11.        Else
  12.        x = 0
  13.     End If
  14.     For i = 1 To Worksheets.Count - 1  '循环各表格
  15.         Set sht = Worksheets(i)  '将活动工作表赋予变量

  17.         Set rng = sht.UsedRange.Find(Target)  '在已用区域中查找数字或文本
  18.         If Not rng Is Nothing Then  '如果已经找到
  19.             FirstAddress = rng.Address  '记录下这个单元格的址
  20.             Do  '启动循环
  21.                 Set rng = sht.UsedRange.Find(Target, rng, , xlWhole)  '继续查找（上一次找到的单元格后面开始查找)
  22.                 FindCount = FindCount + 1  '累加计数器
  23.                 '找到目标后，将目标所在行的2个单元格一起复制到新工作表中去(从上到下按顺序罗列)
  24.                 Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = Worksheets(i).Name
  25.                 rng.Offset(0, x).Resize(1, 2).Copy Worksheets(Worksheets.Count).Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
  26.                 '如果当前找到的目标单元格地址等于第一次记录的单元格地址，那么结束循环
  27.                 If rng.Address = FirstAddress Then Exit Do
  28.             Loop
  29.         End If
  30.     Next
  31.   
  32.     Range("a1").CurrentRegion.Borders.LineStyle = xlContinuous  '对已用区域添加边框
  33.   Range("a1").CurrentRegion.EntireColumn.AutoFit  '自动调整列宽
  34.   Range("A1:d1").Interior.Color = 13020235  '设置背景色
  35.   Range(Cells(3, 1), Cells(20, 1)).Clear '清除空白的单元格   ' rng1 = Cells(Rows.Count, 4).End(xlUp)
  36.   ' If rng1.Rows.Count > 3 Then Range(Cells(1, 3), Cells(Rows.Count, 4).End(xlUp)).Clear '清除上次查询结果  动态方法试验不成功
  37.    
  38. End Sub
20楼
本人号被盗，		 又变动了点，但是觉得罗总一定有更好的答案
  1. Sub Worksheet_Change(ByVal Target As Range)
  2.     If Intersect(Target, Range("a2")) Is Nothing Then Exit Sub '如果不是点击A2单元格，退出sub
  3.    Range(Cells(2, 2), Cells(Rows.Count, 4).End(xlUp)).Clear '清除上次查询结果
  4.    

  6. Range("A1:d1") = Array("查询条件", "班级", "姓名", "成绩") '生成标题行
  7.     Dim i As Byte, sht As Worksheet, rng As Range, rng1 As Range, FirstAddress As String, FindCount As Integer, x As Integer '定义变量
  8.     If IsNumeric(Target) = True Then '利用判断，设置变量，吸取别人精华
  9.        x = -1
  10.        Else
  11.        x = 0
  12.     End If
  13.     For i = 1 To Worksheets.Count - 1  '循环各表格
  14.         Set sht = Worksheets(i)  '将活动工作表赋予变量

  16.         Set rng = sht.UsedRange.Find(Target)  '在已用区域中查找数字或文本
  17.         If Not rng Is Nothing Then  '如果已经找到
  18.             FirstAddress = rng.Address  '记录下这个单元格的址
  19.             Do  '启动循环
  20.                 Set rng = sht.UsedRange.Find(Target, rng, , xlWhole)  '继续查找（上一次找到的单元格后面开始查找)
  21.                 FindCount = FindCount + 1  '累加计数器
  22.                 '找到目标后，将目标所在行的2个单元格一起复制到新工作表中去(从上到下按顺序罗列)
  23.                 Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = Worksheets(i).Name
  24.                 rng.Offset(0, x).Resize(1, 2).Copy Worksheets(Worksheets.Count).Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
  25.                 '如果当前找到的目标单元格地址等于第一次记录的单元格地址，那么结束循环
  26.                 If rng.Address = FirstAddress Then Exit Do
  27.             Loop
  28.         End If
  29.     Next
  30.   
  31. Range("a1").CurrentRegion.Borders.LineStyle = xlContinuous  '对已用区域添加边框
  32. Range("a1").CurrentRegion.EntireColumn.AutoFit  '自动调整列宽
  33. Range("A1:d1").Interior.Color = 13020235  '设置背景色

  35.   Range(Cells(3, 1), Cells(IIf(Cells(Rows.Count, 4).End(xlUp).Row > 3, Cells(Rows.Count, 4).End(xlUp).Row, 3), 1)).Clear '清除空白的单元格

  37. End Sub
21楼
罗刚君		 提示：此题目是“VBA入门免费教学群”（群号:30729794）的课后作业
请未参与听课者绕道，谢谢配合。

_____________________________________________________



第23课作业题二.rar


 
请在附件的数据基础上，利用代码实现动画效果。

提示：
实现以上功能需要用到以下知识点，你也可以不用，能实现功能就行了：
1.IsNumeric，用于判断输入的字符是数字还是文本
2.工作表事件，修改单元格时代码可以自动执行
3.Range.Find方法，查找数据
4.条件语句If Then
5.循环语句For Next或者For Each...Next
6.Range.Offset \Range.Resize等属性的应用
7.Range.Copy方法，用于复制单元格或者区域
以上内容全都上过课了，可以轻松实现

_____________________________________________________

第23课作业题二答案.rar
22楼
liaozhifa33		 宁静致远

放置位置：Worksheets("查询界面")代码
总体思路:
1 、当A2单元格改变时执行程序
2、判断A2是数字还是文本
3、循环各表，Range.Find方法，查找数据放到查询表中
4、A2变为空时，清空已经查询的数据
说明:
表中关于find的内容借鉴“客城小生”在
  1. '==========================开始========================
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3. '====================当A2单元格发生改变时候执行==================
  4. If Target.Address = "$A$2" Then
  5. Application.ScreenUpdating = False
  6.     Dim i As Byte, rng As Range, FirstAddress As String, sht As Worksheet, FindCount As Integer '声明变量
  7.     '----------------当A2为数字时候执行-------------------------
  8.     If Len(Range("A2")) <> 0 And IsNumeric(Range("A2")) Then       '判断A2是否为空，以及是否为数字
  9.         Range("B2:D" & Cells.SpecialCells(xlCellTypeLastCell).Row).ClearContents       '清空数据区域的内容
  10.         For i = 1 To Worksheets.Count       '遍历除最后一个表的每个工作表
  11.             Set sht = Worksheets(i)       'sht赋值
  12.             If IsEmpty(sht.UsedRange) Then sht.Delete       '删除空表
  13.             If sht.Name = "查询界面" Then Exit For       '不在查询表中查找
  14.             Set rng = sht.UsedRange.Find(Worksheets("查询界面").Range("A2").Value)       '在已用区域中查找A2的值
  15.             If Not rng Is Nothing Then       '如果已经找到
  16.                 FirstAddress = rng.Address       '记录下这个单元格的址
  17.                 Do       '启动循环
  18.                     Set rng = sht.UsedRange.Find(Worksheets("查询界面").Range("A2").Value, rng, , xlWhole)  '继续查找（上一次找到的单元格后面开始查找)
  19.                     FindCount = FindCount + 1       '累加计数器
  20.                     '找到目标后，将目标所在行的2个单元格一起复制到新工作表中去(从上到下按顺序罗列)
  21.                     rng.Offset(0, -1).Resize(1, 2).Copy Worksheets("查询界面").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
  22.                     '将单元格所在的表名写在班级列
  23.                     Worksheets("查询界面").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = sht.Name
  24.                     '如果当前找到的目标单元格地址等于第一次记录的单元格地址，那么结束循环
  25.                     If rng.Address = FirstAddress Then Exit Do
  26.                 Loop
  27.                 ActiveSheet.UsedRange.Borders.LineStyle = xlNone       '清除边框
  28.                 With Range("A1:A2,B2:D" & Cells(Rows.Count, 4).End(3).Row)
  29.                     .Borders.LineStyle = 1       '对已用区域添加边框
  30.                     .EntireColumn.AutoFit        '自动调整列宽
  31.                     .HorizontalAlignment = xlCenter       '水平居中
  32.                     .VerticalAlignment = xlCenter         '垂直居中
  33.                 End With
  34.             End If
  35.         Next
  36.     Else
  37.     '----------------当A2为文本时候执行-------------------------
  38.         If Len(Range("A2")) <> 0 And IsNumeric(Range("A2")) = False Then       '判断A2是否为空，以及是否为数字
  39.         Range("B2:D" & Cells.SpecialCells(xlCellTypeLastCell).Row).ClearContents       '清空数据区域的内容
  40.         For i = 1 To Worksheets.Count       '遍历除最后一个表的每个工作表
  41.             Set sht = Worksheets(i)       'sht赋值
  42.             If IsEmpty(sht.UsedRange) Then sht.Delete       '删除空表
  43.             If sht.Name = "查询界面" Then Exit For       '不在查询表中查找
  44.             Set rng = sht.UsedRange.Find("*" & Worksheets("查询界面").Range("A2").Value & "*")       '在已用区域中查找A2的值：模糊查询
  45.             If Not rng Is Nothing Then       '如果已经找到
  46.                 FirstAddress = rng.Address       '记录下这个单元格的址
  47.                 Do       '启动循环
  48.                     Set rng = sht.UsedRange.Find("*" & Worksheets("查询界面").Range("A2").Value & "*", rng, , xlPart) '继续查找（上一次找到的单元格后面开始查找)
  49.                     FindCount = FindCount + 1       '累加计数器
  50.                     '找到目标后，将目标所在行的2个单元格一起复制到新工作表中去(从上到下按顺序罗列)
  51.                     rng.Resize(1, 2).Copy Worksheets("查询界面").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
  52.                     '将单元格所在的表名写在班级列
  53.                     Worksheets("查询界面").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = sht.Name
  54.                     '如果当前找到的目标单元格地址等于第一次记录的单元格地址，那么结束循环
  55.                     If rng.Address = FirstAddress Then Exit Do
  56.                 Loop
  57.                 ActiveSheet.UsedRange.Borders.LineStyle = xlNone       '清除边框
  58.                 With Range("A1:A2,B2:D" & Cells(Rows.Count, 4).End(3).Row)
  59.                     .Borders.LineStyle = 1       '对已用区域添加边框
  60.                     .EntireColumn.AutoFit        '自动调整列宽
  61.                     .HorizontalAlignment = xlCenter        '水平居中
  62.                     .VerticalAlignment = xlCenter          '垂直居中
  63.                 End With
  64.             End If
  65.         Next
  66.         Else
  67.     '----------------当A2值被清空时候执行-------------------------
  68.             If Len(Range("A2")) = 0 Or Range("A2") Is Nothing Then      '判断A2是否为空，或者是否为空
  69.             Range("B2:D" & Cells.SpecialCells(xlCellTypeLastCell).Row).ClearContents
  70.             'A2内容被删除时候，清空已有查询内容
  71.                 ActiveSheet.UsedRange.Borders.LineStyle = xlNone        '清除边框
  72.                 With Range("A1:A2,B2:D" & Cells(Rows.Count, 4).End(3).Row)
  73.                     .Borders.LineStyle = 1       '对已用区域添加边框
  74.                     .EntireColumn.AutoFit        '自动调整列宽
  75.                     .HorizontalAlignment = xlCenter       '水平居中
  76.                     .VerticalAlignment = xlCenter         '垂直居中
  77.                 End With
  78.            End If
  79.         End If
  80.     End If
  81. Application.ScreenUpdating = True
  82. End If
  83. End Sub
  84. '==========================结束========================
23楼
ynzsvt		 Private Sub Worksheet_Change(ByVal Target As Range) '在设计好第一行表格的基础上
Dim Rng As Range '声明变量
If Target.Address <> [a2].Address Then Exit Sub '仅对A2单元格输入有效。
Application.EnableEvents = False
Set Rng = [b2]
Rng.Resize(Cells(Rows.Count, "B").End(xlUp).Row, 3).Clear  '原有数据清空，不保留边框格式。为确保空白时不出错，多删除了一行
Application.ScreenUpdating = False
[a2] = Trim([a2])
If IsNumeric([a2]) Then FindA2 (2) Else FindA2 (1) '决定查找数字还是姓名，空白查找成绩空白的
Application.ScreenUpdating = True
Application.EnableEvents = True
[a2].Select
End Sub

Sub FindA2(ByVal i As Integer) '参数是查找的列号
Dim Rng As Range, FirstAddress As String, sht As Worksheet, FindCount As Integer, FindStr$, MsgStr '声明变量
MsgStr = Array("姓名含 ", "成绩=") '不同的未找到显示信息
Select Case i '不同的查找
Case 1
  FindStr = "*" & [a2] & "*"
Case 2
  FindStr = [a2]
Case Else
  Exit Sub
End Select
For Each sht In Worksheets
  With sht
   If .Name <> ActiveSheet.Name Then '查询界面表格不查找
    Set Rng = .Columns(i).Find(FindStr)  '在第i列中查找
    If Not Rng Is Nothing Then  '如果已经找到
     If Rng.Row <= .Cells(Rows.Count, "A").End(xlUp).Row Then
      FirstAddress = Rng.Address  '记录下这个单元格的地址
      Do  '启动循环
       FindCount = FindCount + 1  '累加计数器
       Rng.Offset(0, 1 - i).Resize(1, 2).Copy Cells(Rows.Count, 2).End(xlUp).Offset(1, 1) '整行数据
       ActiveSheet.Hyperlinks.Add Anchor:=Cells(Rows.Count, 2).End(xlUp).Offset(1, 0), Address:="", SubAddress:=.Name & "!" & Rng.Address, _
         TextToDisplay:=.Name   '以链接显示
       Set Rng = .Columns(i).Find(FindStr, Rng, , xlWhole)  '继续查找（上一次找到的单元格后面开始查找)
       If Rng.Row > .Cells(Rows.Count, "A").End(xlUp).Row Then Exit Do '找到超出末尾
      Loop While Rng.Address <> FirstAddress '如果当前找到的目标单元格地址不等于第一次记录的单元格地址，那么继续循环
     End If
    End If
   End If
  End With
Next sht
If FindCount = 0 Then
  MsgBox MsgStr(i - 1) & [a2], , "找不到"
Else
  Set Rng = [b2]
  Rng.Resize(FindCount, 3).Borders.LineStyle = 1 '数据区域加边框
End If
End Sub
24楼
胖头鱼tx		 第一次交作业 没能使用find和resize,有很多缺点，老师见谅。
第23课作业题二.zip
25楼
wangxf9209		 江苏-雪峰
自己觉得有2个遗憾：
   1是没用上IsNumeric；
   2是当同一表中有多个符合条件的记录，第1个总是排在最后复制到查询界面，当然，将19、20、21三行代码复制到DO之前，并且将22行移到18行下面，即可避免。
另外，我觉得罗老师的这种循环查找的方法比用FINDNEXT更简单些。
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. Dim SHT As Worksheet, RNG As Range, I As Integer, N As Integer, K As Boolean
  3. Application.ScreenUpdating = False   '关闭屏幕更新，但是为什么接下来还是能看到逐个粘贴单元格的操作？
  4. If Target.Address = "$A$2" Then     '判断修改的单元格是A2时才执行下面的代码
  5.     With Worksheets("查询界面")     '建立with语句
  6.         .Range("B2:D1000").Clear            '清空显示区域的所有内容
  7.         For I = 1 To Worksheets.Count - 1   '建立循环，从第1个工作表循环到倒数第2个
  8.             Set SHT = Worksheets(I)        '将循环到的工作表赋值给变量
  9.             Set RNG = SHT.Cells.Find(What:=Range("A2").Value, After:=SHT.[A1], LookIn:=xlFormulas, LookAt:= _
  10.                 xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
  11.                 , MatchByte:=False, SearchFormat:=False)       '行查找一遍
  12.             If Not RNG Is Nothing Then            '如果查找到了单元格，就继续执行下面的代码，否则循环下一工作表
  13.                 FirstAddress = RNG.Address    '记下刚才查找到的单元格的地址
  14.                 K = True                      '用变量K记录是否查找到至少一单元格
  15.                 Do                                '建立DO循环
  16.                 Set RNG = SHT.Cells.Find(What:=Range("A2").Value, After:=RNG, LookIn:=xlFormulas, LookAt:= _
  17.                         xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
  18.                         , MatchByte:=False, SearchFormat:=False)   '从上次查找出的单元格往后继续查找
  19.                   N = .Cells(Rows.Count, 2).End(xlUp).Row         '取得查询界面B列最后一个非空单元格的行号
  20.                 .Cells(N + 1, 2) = SHT.Name                       '将查询到的单元格所在工作表名称填入B列
  21.                 SHT.Cells(RNG.Row, 1).Resize(1, 2).Copy .Cells(N + 1, 3)   '将查找到的单元格所在行的A、B列2个单元格复制并粘贴到查询界面
  22.                 If RNG.Address = FirstAddress Then Exit Do        '判断如果此次查找到的单元格地址与前面记录的地址一样，那么结束DO循环
  23.                 Loop
  24.             End If
  25.         Next
  26.         If K Then
  27.             Range("B2", Cells(N + 1, 4)).Borders.LineStyle = 1   '将查找到的记录加上边框，虽然复制过来的可能已经有边框，
  28.         Else
  29.             Range("B2") = "没有查找到符合条件的记录！"   '如果一个符合条件的单元格都没有找到，K的值应该为FALSE，则在B2显示提示文字。
  30.         End If
  31.     End With
  32. End If
  33. Application.ScreenUpdating = True
  34. End Sub
26楼
kcxs		 客城小生的作业，以下代码放在“查询界面”工作表：
  1. Private Sub Worksheet_Change(ByVal Target As Range) '工作表事件
  2. If Target.Address = "$A$2" Then '如果被修改的单元格的址是A2
  3.         '清除上次查询记录
  4.         If Cells(2, 2) <> "" Then
  5.         Range("B2:D2").Select
  6.         Range(Selection, Selection.End(xlDown)).Select
  7.         Selection.Clear
  8.         End If
  9.           '对"B2:D10"区域添加边框
  10.         Range("B2:D10").Select
  11.         Selection.Borders(xlDiagonalDown).LineStyle = xlNone
  12.         Selection.Borders(xlDiagonalUp).LineStyle = xlNone
  13.         With Selection.Borders(xlEdgeLeft)
  14.             .LineStyle = xlContinuous
  15.             .Weight = xlThin
  16.             .ColorIndex = xlAutomatic
  17.         End With
  18.         With Selection.Borders(xlEdgeTop)
  19.             .LineStyle = xlContinuous
  20.             .Weight = xlThin
  21.             .ColorIndex = xlAutomatic
  22.         End With
  23.         With Selection.Borders(xlEdgeBottom)
  24.             .LineStyle = xlContinuous
  25.             .Weight = xlThin
  26.             .ColorIndex = xlAutomatic
  27.         End With
  28.         With Selection.Borders(xlEdgeRight)
  29.             .LineStyle = xlContinuous
  30.             .Weight = xlThin
  31.             .ColorIndex = xlAutomatic
  32.         End With
  33.         With Selection.Borders(xlInsideVertical)
  34.             .LineStyle = xlContinuous
  35.             .Weight = xlThin
  36.             .ColorIndex = xlAutomatic
  37.         End With
  38.         With Selection.Borders(xlInsideHorizontal)
  39.             .LineStyle = xlContinuous
  40.             .Weight = xlThin
  41.             .ColorIndex = xlAutomatic
  42.         End With
  43.         Cells(2, 1).Select '激活查询单元格
  44.     Application.ScreenUpdating = False '关闭屏幕更新，加快代码速度
  45.     Dim Rng As Range, FirstAddress As String, Mc As String, sht As Worksheet, TargetCount As Integer, i As Integer '定义变量
  46.     Mc = Cells(2, 1).Value
  47.     If IsNumeric(Mc) Then
  48.       For i = 1 To Worksheets.Count - 1  '遍历第1到倒数第二个工作表
  49.         Set sht = Worksheets(i)
  50.         Set Rng = sht.Columns(2).Find(Mc)   '在第i个工作表的B列查找与成绩相符的单元格
  51.         If Not Rng Is Nothing Then   '如果已经找到
  52.           FirstAddress = Rng.Address  '记录下它的地址
  53.           Do  '启动循环
  54.             Set Rng = sht.Columns(2).Find(Mc, Rng, , xlWhole) '在rng之后继续查找
  55.             TargetCount = TargetCount + 1  '累加计数器
  56.             '找到后先左移1列，然后重置区域为1行2列，从而得到该行的所有非空单元格，将它们复制到"查询界面"表C列最后一个非空单元格的下一格
  57.             Rng.Offset(0, -1).Resize(1, 2).Copy Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
  58.             Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = sht.Name '对B列赋值为工作表名(班级)
  59.             '如果当前找到的目标单元格地址等于第一次找到的目标单元格地址，那么结束循环
  60.             If Rng.Address = FirstAddress Then Exit Do
  61.           Loop
  62.         End If
  63.       Next  '下一个表
  64.     Else
  65.       For i = 1 To Worksheets.Count - 1  '遍历第1到倒数第二个工作表
  66.         Set sht = Worksheets(i)
  67.         Set Rng = sht.Columns(1).Find(Mc)  '在第i个工作表的A列查找与姓名相符的单元格
  68.         If Not Rng Is Nothing Then   '如果已经找到
  69.           FirstAddress = Rng.Address  '记录下它的地址
  70.           Do  '启动循环
  71.             Set Rng = sht.Columns(1).Find(Mc, Rng, , xlWhole) '在rng之后继续查找
  72.             TargetCount = TargetCount + 1  '累加计数器
  73.             '找到后重置区域为1行2列，从而得到该行的所有非空单元格，将它们复制到"查询界面"表C列最后一个非空单元格的下一格
  74.             Rng.Offset(0, 0).Resize(1, 2).Copy Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
  75.             Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = sht.Name '对B列赋值为工作表名(班级)
  76.             '如果当前找到的目标单元格地址等于第一次找到的目标单元格地址，那么结束循环
  77.             If Rng.Address = FirstAddress Then Exit Do
  78.           Loop
  79.         End If
  80.       Next  '下一个表
  81.     End If
  82.       Application.DisplayAlerts = True   '恢复提示
  83.       Range("a1").CurrentRegion.EntireColumn.AutoFit '自动调整列宽
  84.       MsgBox "找到" & TargetCount & "个目标", vbOKOnly + vbInformation, "友情提示"
  85.     Application.ScreenUpdating = True '恢复闭屏幕更新
  86. End If
  87. End Sub

27楼
一点点
  1. 糊啦啦
  2. Sub zuoy2()    '查找结果不分先后，嘿嘿
  3.     Dim ish As Byte: Dim ifind As Byte: Dim irow As Byte: Dim iend As Byte   '声明行数变量
  4.     Dim rng As Range: Dim ifnd As Range                                      '声明单元格类型变量
  5.     Dim idree As String                                                      '声明字符串类型的变量
  6.     Dim ifc As Byte                                                          '数值变量记录循环次数

  8.     Sheets("查询界面").Range("b2:d10000").ClearContents                       '清空上次查询结果
  9. '========================================================================================================== 以下是代码
  10.     Set rng = Sheets("查询界面").Range("a2")                                   '给单元格变量指定位置

  12.     If IsNumeric(rng.Value) Then                                               '判断单元格内容是否为数值型

  14.         For ish = 1 To Sheets.Count - 1                                        '如果是数值型内容，则循环工作表的个数

  16.             Set ifnd = Sheets(ish).Range("a:b").Find(rng)                      '把符合要求的单元格赋值给单元格变量ifnd

  18.             If Not ifnd Is Nothing Then                                        '如果找到符合条件的单元格,继续执行，否则循环下一个工作表

  20.                 idree = ifnd.Address                                           '把符合要求的单元格地址记录下来

  22.                 Do                                                             'do循环

  24.                     Set ifnd = Sheets(ish).Range("a:b").Find(rng, ifnd, , xlWhole) '继续往下查找

  26.                     ifc = ifc + 1                                                '记录循环次数

  28.                                                                                  '把当前循环的工作表名放入查询界面的B列最后一个非空单元格里
  29.                     Sheets("查询界面").Range("b" & Cells(Rows.Count, 3).End(3).Row + 1) = Sheets(ish).Name

  31.                                                                                  '把找到符合要求的行内容复制到查询界面CD列的最后一个非空单元格里
  32.                     ifnd.Offset(0, -1).Resize(1, 2).Copy Sheets("查询界面").Range("c" & Cells(Rows.Count, 3).End(3).Row + 1)

  34.                     If ifnd.Address = idree Then Exit Do                         '判断当前找到的目标单元格地址是否等于第一次记录的单元格地址，如果是就结束循环，否则继续查找

  36.                 Loop                                                              'do循环结束语

  38.             End If

  40.         Next ish

  42.     Else

  44.         For ish = 1 To Sheets.Count - 1                                        '如果是数值型内容，则循环工作表的个数

  46.             Set ifnd = Sheets(ish).Range("a:b").Find("*" & rng & "*")           '把符合要求的单元格赋值给单元格变量ifnd

  48.             If Not ifnd Is Nothing Then                                        '如果找到符合条件的单元格,继续执行，否则循环下一个工作表

  50.                 idree = ifnd.Address                                           '把符合要求的单元格地址记录下来
  51.                 Debug.Print idree

  53.                 Do                                                             'do循环

  55.                     Set ifnd = Sheets(ish).Range("a:b").Find("*" & rng & "*", ifnd, , xlWhole) '继续往下查找

  57.                     ifc = ifc + 1                                                '记录循环次数

  59.                                                                                   '把当前循环的工作表名放入查询界面的B列最后一个非空单元格里
  60.                     Sheets("查询界面").Range("b" & Cells(Rows.Count, 3).End(3).Row + 1) = Sheets(ish).Name

  62.                                                                                   '把找到符合要求的行内容复制到查询界面CD列的最后一个非空单元格里
  63.                     ifnd.Resize(1, 2).Copy Sheets("查询界面").Range("c" & Cells(Rows.Count, 3).End(3).Row + 1)

  65.                     If ifnd.Address = idree Then Exit Do                         '判断当前找到的目标单元格地址是否等于第一次记录的单元格地址，如果是就结束循环，否则继续查找

  67.                 Loop                                                              'do循环结束语

  69.             End If

  71.         Next ish

  73.     End If

  75. End Sub
这次全注释了好认真哦
28楼
lfwxszw		 群名片：简单
在查询界面的worksheet_change里录入以下代码

Private Sub Worksheet_Change(ByVal Target As Range)
'worksheet_change事件的TARGET是 失去焦点前的单元格
'焦点失去前如果单元格地址是A2 那么
If Target.Address = Range("a2").Address Then
Call 多表多内容查询
End If
End Sub
  1. Sub 多表多内容查询()
  2. '=================================================
  3. ' For Each .. Next
  4. '此方法，不用考虑  查询界面，在工作簿中的位置,不用考虑要查找的数据在第几列
  5. '=============================================
  6. '关闭屏幕更新
  7. Application.ScreenUpdating = False
  8. '容错
  9. On Error Resume Next
  10. '定义变量
  11. Dim rng As Range, firstaddress As String, sht As Worksheet, hd As Range, tj
  12. Set hd = Worksheets("查询界面").UsedRange
  13. '清除B2开始到已用区域最大行 列的值
  14. Range(Cells(2, 2), Cells(hd.Rows.Count, hd.Columns.Count)).Clear
  15. '变量条件(tj)赋值
  16. tj = Cells(2, 1)
  17.     For Each sht In Worksheets
  18.          '如果表名不是 查询界面 那么就查找
  19.         If sht.Name <> "查询界面" Then
  20.               '查询 tj 完全匹配，按行查找
  21.               Set rng = sht.UsedRange.Find(tj, , , xlWhole, xlByRows)
  22.                  '如果找到
  23.                  If Not rng Is Nothing Then
  24.                  '赋值给firstaddress
  25.                  firstaddress = rng.Address
  26.                  Do
  27.                  '在firstaddress后继续查找
  28.                  Set rng = sht.UsedRange.Find(tj, rng, , xlWhole, xlByRows)
  29.                  'B列非空下一单元格，为sht.name名，且设置边框
  30.                  Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = sht.Name
  31.                  Cells(Rows.Count, 2).End(xlUp).Borders.LineStyle = xlContinuous
  32.                  '目标偏移 －行号+1，重置（1行，当前区域列数和 列） 复制到 第3列非空下一格
  33.                  rng.Offset(0, -rng.Column + 1).Resize(1, rng.CurrentRegion.Columns.Count).Copy Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
  34.                  '直到找到地址与第一次相同停止
  35.                  Loop Until rng.Address = firstaddress
  36.                  End If
  37.         End If
  38.     Next '下一个表
  39.     '开启屏幕更新，已用区域自动列宽
  40.     Application.ScreenUpdating = True
  41.     hd.EntireColumn.AutoFit
  42. End Sub
29楼
冰淇林的冬天		 群号:30729794
冰激凌的冬天
第23课作业题二.rar
30楼
大猫
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.     Dim rg As Range, rgg As Range, i%, X%, a%, rg2 As Range
  3.    If Target = Range("a2") Then '点击A2时起动事件
  4.     Range("b2:d10").ClearContents
  5.     For i = 1 To 5
  6.         X = X + 1
  7.         If IsNumeric(Range("a2")) Then    '判别是否是文本
  8.             Set rgg = Sheets(X).Range("b2:b11")    '数值
  9.             For Each rg In rgg
  10.                 If rg = Sheets(6).Range("a2") Then
  11.                     Sheets(6).Range("d65536").End(xlUp).Offset(1, 0) = rg
  12.                     Sheets(6).Range("C65536").End(xlUp).Offset(1, 0) = rg.Offset(0, -1)
  13.                     Sheets(6).Range("b65536").End(xlUp).Offset(1, 0) = Sheets(X).Name
  14.                 End If
  15.             Next
  16.         Else
  17.             Set rgg = Sheets(X).Range("a2:a11")    '文本
  18.             For Each rg In rgg
  19.                 Set rg2 = rg.Find(Sheets(6).Range("a2") & "*", rg) '按姓模糊查找
  20.                 If Not rg2 Is Nothing Then
  21.                     Sheets(6).Range("c65536").End(xlUp).Offset(1, 0) = rg
  22.                     Sheets(6).Range("d65536").End(xlUp).Offset(1, 0) = rg.Offset(0, 1)
  23.                     Sheets(6).Range("b65536").End(xlUp).Offset(1, 0) = Sheets(X).Name
  24.                 End If
  25.             Next
  26.         End If
  27.     Next
  28. End If
  29. 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