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

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

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

请用For Next和For Each Next两种循环语句套用实用以下功能：
参照动画，罗列Sheet1的每个科目的最后一名的姓名和成绩，保存在Sheet2中

 

提示：计算一个区域的最小值可用Worksheetfunction.Min函数

22课题目.rar


补充：请尽量不要用数组的知识，还没有上课到那里。_____________________________________________________
补充：“VBA入门免费教学群”（群号:30729794）每周三上课一次，有兴趣者皆可报名，永远免费。
请提交作业时注明在免费听课群的昵称。三次不交作业者，将踢出群，让出空间让更多的人进来听课，请大家配合。
2楼
ynzsvt		 Sub test()
Dim Arr, Brr(), i%, j%, Rng As Range
Set Rng = Sheets(2).[A1]
Arr = Sheets(1).UsedRange
ReDim Brr(1 To UBound(Arr, 2), 1 To 3)
For j = 2 To UBound(Arr, 2)
  Brr(j, 3) = 100: Brr(j, 1) = Arr(1, j)
  For i = 2 To UBound(Arr)
   If Arr(i, j) = Brr(j, 3) Then Brr(j, 2) = Brr(j, 2) & Chr(10) & Arr(i, 1)
   If Arr(i, j) < Brr(j, 3) Then Brr(j, 2) = Arr(i, 1): Brr(j, 3) = Arr(i, j)
  Next i
Next j
Rng.Resize(UBound(Arr, 2), 3) = Brr
Rng.Resize(1, 3) = Array("课目", "姓名", "成绩")
End Sub
3楼
manuel442		 昵称：智山仁水
Sub 罗列最小值()
Dim rng As Range
Dim cell As Range
Dim cell2 As Range
Dim i As Integer
Dim mini As Integer
Dim j As Integer
Set rng = Sheets(1).UsedRange
    Sheets(2).Cells(1, 1) = "科目"
    Sheets(2).Cells(1, 2) = "姓名"
    Sheets(2).Cells(1, 3) = "成绩"
    j = 1
    For Each cell In rng.Offset(, 1).Resize(1, rng.Columns.Count - 1)
        i = i + 1
        mini = WorksheetFunction.min(rng.Offset(, i).Resize(, 1))
        For Each cell2 In rng.Offset(, i).Resize(, 1)
            If cell2 = mini Then
                Sheets(2).Cells(1, 2).Offset(j) = cell2.Offset(0, -i)
                Sheets(2).Cells(1, 1).Offset(j) = cell
                Sheets(2).Cells(1, 3).Offset(j) = mini
                j = j + 1
            End If
        Next
    Next
   
End Sub
4楼
爱情和面包		 Sub Text()
Dim Arr(), i As Byte, x As Byte, y As Byte
For y = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
    Mi = WorksheetFunction.Min(Cells(2, y).Resize(Cells(Rows.Count, 1).End(3).Row - 1))
        For x = 2 To Cells(Rows.Count, 1).End(3).Row
                If Cells(x, y) = Mi Then
                    K = K + 1
                    ReDim Preserve Arr(1 To 3, 1 To K)
                        Arr(1, K) = Cells(1, y)
                        Arr(2, K) = Cells(x, 1)
                        Arr(3, K) = Cells(x, y)
                End If
         Next
Next

With Sheets(2)
  .UsedRange.ClearContents
  .Cells(1, 1) = "科目": .Cells(1, 2) = "姓名": .Cells(1, 3) = "成绩"
   Sheets(2).Cells(2, 1).Resize(K, 3) = WorksheetFunction.Transpose(Arr)
End With
End Sub
5楼
kcxs		 客城小生的作业
以下代码适用于无重复值科目
  1. Sub test()
  2.     Sheets("sheet1").Select
  3.     Dim i As Byte, rng As Range
  4.     For i = 2 To 6
  5.     For Each rng In Range(Cells(2, i), Cells(2, i).End(xlDown))
  6.         If rng = WorksheetFunction.Min(Range(Cells(2, i), Cells(2, i).End(xlDown))) Then
  7.             '将最低分的科目、姓名和成绩罗列在sheet2的A、B、C列
  8.             Sheets("sheet2").Cells(i, "A") = Cells(1, i).Text
  9.             Sheets("sheet2").Cells(i, "B") = rng.Offset(0, 1 - i).Text
  10.             Sheets("sheet2").Cells(i, "C") = rng.Offset(0, 0).Text
  11.         End If
  12.     Next rng
  13.     Next
  14.     Sheets("sheet2").Select
  15.         [a1] = "科目"
  16.         [b1] = "姓名"
  17.         [c1] = "成绩"
  18. End Sub

6楼
爱情和面包		 Sub Text()
Dim Arr(), i As Byte, x As Byte, y As Byte
Sheets(2).UsedRange.ClearContents
Sheets(2).Cells(1, 1) = "科目": Sheets(2).Cells(1, 2) = "姓名": Sheets(2).Cells(1, 3) = "成绩"
For y = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
    Mi = WorksheetFunction.Min(Cells(2, y).Resize(Cells(Rows.Count, 1).End(3).Row - 1))
        For x = 2 To Cells(Rows.Count, 1).End(3).Row
                If Cells(x, y) = Mi Then
                       k = k + 1
                       Sheets(2).Cells(1, 1).Offset(k) = Cells(1, y)
                       Sheets(2).Cells(1, 2).Offset(k) = Cells(x, 1)
                       Sheets(2).Cells(1, 3).Offset(k) = Cells(x, y)
                    
                End If
         Next
Next
End Sub
7楼
ynzsvt		 Sub text()
Dim j%, Rng1 As Range, RngFirst$, Rngo As Range, MinKe
Set Rngo = Sheets(2).[A2]
Sheets(1).Select
For j = 2 To Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
  MinKe = Application.WorksheetFunction.Min(Sheets(1).Columns(j))
  Set Rng1 = Columns(j).Find(What:=MinKe)
  Rngo = Cells(1, j): Rngo.Offset(0, 1) = Rng1.Offset(0, 1 - j): Rngo.Offset(0, 2) = MinKe
  Set Rngo = Rngo.Offset(1, 0)
  RngFirst = Rng1.Address
  Set Rng1 = Columns(j).FindNext(Rng1)
  While Rng1.Address <> RngFirst
   Rngo = Cells(1, j): Rngo.Offset(0, 1) = Rng1.Offset(0, 1 - j): Rngo.Offset(0, 2) = MinKe
   Set Rngo = Rngo.Offset(1, 0)
   Set Rng1 = Columns(j).FindNext(Rng1)
  Wend
Next j
Sheets(2).[A1].Resize(1, 3) = Array("课目", "姓名", "成绩")
End Sub
8楼
LurYangHer		 From VBA入门免费教学群
@BatisHe


Sub 作业22()
    Dim CNum As Integer
    Dim RNum As Integer
    Dim MinCJ As Byte
    Dim i As Integer
    Dim j As Integer
    j = 2
    CNum = Sheet1.Range("A1").End(xlToRight).Column
    RNum = Sheet1.Range("A1").End(xlDown).Row
    Sheet2.Range("A1").Value = "科目"
    Sheet2.Range("B1").Value = "姓名"
    Sheet2.Range("C1").Value = "科目最低成绩"
    For i = 2 To CNum
        MinCJ = Application.WorksheetFunction.Min(Range(Sheet1.Cells(2, i), Sheet1.Cells(RNum, i)))
        For Each one In Range(Sheet1.Cells(2, i), Sheet1.Cells(RNum, i))
            If one.Value = MinCJ Then
               Sheet2.Cells(j, 1) = Sheet1.Cells(1, i).Value
               Sheet2.Cells(j, 2) = Sheet1.Cells(one.Row, 1).Value
               Sheet2.Cells(j, 3) = Sheet1.Cells(one.Row, i).Value
               j = j + 1
            End If
        Next one
    Next i
End Sub
9楼
lfwxszw		 群名片：简单27044519

第一种：FOR NEXXT

Sub 最小分数()
Dim rng As Range '分数所在单元格
Dim lh As Byte '列号
Dim km As Range ' 科目
Dim xm As Range '姓名
Application.DisplayAlerts = False

'查找列数从第2至最后已用列
For lh = 2 To Worksheets("sheet1").UsedRange.End(2).Column

'在 列号 列中查找最小值
Set rng = Worksheets("sheet1").Columns(lh).Find(WorksheetFunction.Min(Columns(lh)), , , xlWhole)
'科目 值是 最小分数向上查找 行号+1
Set km = rng.Offset(-rng.Row + 1, 0)
'姓名 值是 最小分数向左查找 列号+1
Set xm = rng.Offset(0, -rng.Column + 1)

'表2中 第 列号 所在行的第1，2，3列值 转换成相应格式

Sheets("sheet2").Cells(1, 1) = "姓名"
Sheets("sheet2").Cells(1, 2) = "科目"
Sheets("sheet2").Cells(1, 3) = "分数"
Sheets("sheet2").Cells(lh, 1) = CStr(xm)
Sheets("sheet2").Cells(lh, 2) = CStr(km)
Sheets("sheet2").Cells(lh, 3) = CStr(rng)

Next lh
Application.DisplayAlerts = True
End Sub


第二种：不会
10楼
wendel		 无心手语
  1.     Dim Rng As Range, Cell As Range
  2.     Dim nMin As Single, LastRow As Integer, c As Integer
  3.     With Sheets("Sheet2")
  4.         .UsedRange.ClearContents
  5.         .Range("A1:C1") = Array("科目", "姓名", "成绩")
  6.         Sheets("Sheet1").Range("B1:F1").Copy
  7.         .Range("A2").PasteSpecial Paste:=xlPasteValues, Transpose:=True
  8.         Application.CutCopyMode = False
  9.     End With
  10.     With Sheets("Sheet1")
  11.         LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
  12.         For c = 2 To 6
  13.             Set Rng = .Range(.Cells(2, c), .Cells(LastRow, c))
  14.             nMin = WorksheetFunction.Min(Rng)
  15.             For Each Cell In Rng
  16.                 If Cell.Value = nMin Then
  17.                     Sheets("Sheet2").Cells(c, 3) = Cell.Value
  18.                     Sheets("Sheet2").Cells(c, 2) = .Cells(Cell.Row, 1) & " " & Sheets("Sheet2").Cells(c, 2)
  19.                 End If
  20.             Next
  21.         Next
  22.     End With
  23.     Sheets("Sheet2").Columns("B:B").EntireColumn.AutoFit
11楼
paoge		 骑着钓箱看世界


Sub 罗列各科最后一名()
Dim rng As Range, rngclu As Range, i, j, k, rng2 As Range
k = 1
Set rng = ActiveSheet.UsedRange
Set rngclu = rng.Columns
    For i = 2 To rngclu.Count
        sc = WorksheetFunction.Min(rngclu(i))
        For Each rng2 In ActiveSheet.UsedRange.Rows
           If rng.Cells(rng2.Row, i).Value = sc Then
               k = k + 1
                Sheet2.Range("c" & k) = rng.Cells(rng2.Row, i)
                Sheet2.Range("b" & k) = rng.Cells(rng2.Row, "a")
                Sheet2.Range("a" & k) = rng.Cells(1, i)
           End If
        Next
    Next
    Sheet2.Range("a1:c1") = Array("科目", "姓名", "成绩")
    With Sheet2.UsedRange
         .Borders.LineStyle = xlContinuous
         .HorizontalAlignment = xlCenter
     End With
   
End Sub
12楼
芐雨
  1. Sub test()
  2. Dim Rng As Range
  3. Dim x, y, m, n
  4. m = Cells(Rows.Count, 1).End(xlUp).Row
  5. n = Cells(1, Columns.Count).End(xlToLeft).Column
  6. y = 2
  7. Sheet8.Range("a1") = "科目"
  8. Sheet8.Range("b1") = "姓名"
  9. Sheet8.Range("c1") = "成绩"
  10. For x = 2 To n
  11. For Each Rng In Range(Cells(2, x), Cells(m, x))
  12.    If Rng = WorksheetFunction.Min(Range(Cells(2, x), Cells(m, x))) Then
  13.    Sheet8.Cells(y, 3) = Rng
  14.    Sheet8.Cells(y, 2) = Cells(Rng.Row, 1)
  15.    Sheet8.Cells(y, 1) = Cells(1, Rng.Column)
  16.    y = y + 1
  17.    End If
  18.    Next
  19. Next
  20. End Sub
13楼
天空的雨		 22课题目-免费听课群-天空答.rar
14楼
一点点		 不会
  1. Sub zuihuiyiming()
  2.     Dim icom As Byte
  3.     Dim iend As Byte
  4.     Dim yw As Byte, shx As Byte, hx As Byte, dl As Byte, jsj As Byte
  5.     Dim ishe As Worksheet
  6.     Dim ish As Worksheet
  7.     Set ishe = Sheets("sheet1")
  8.     Set ish = Sheets("sheet2")
  9.     iend = ishe.Range("b" & Rows.Count).End(3).Row
  10.    
  11.     ish.Range("a1") = "科目"
  12.     ish.Range("b1") = "姓名"
  13.     ish.Range("c1") = "成绩"
  14.    
  15.     For icom = 2 To 6
  16.         ish.Range("a" & icom) = ishe.Cells(1, icom)
  17.     Next icom
  18.    
  19.     yw = ishe.Range("b:b").Find(Application.Min(ishe.Range("b2:b16"))).Row
  20.     ish.Range("b2") = Range("b" & yw).Offset(0, -1).Value
  21.     ish.Range("c2") = Range("b" & yw)

  23.     shx = ishe.Range("c:c").Find(Application.Min(ishe.Range("c2:c16"))).Row
  24.     ish.Range("b3") = Range("c" & shx).Offset(0, -2).Value
  25.     ish.Range("c3") = Range("c" & shx)

  27.     hx = ishe.Range("d:d").Find(Application.Min(ishe.Range("d2:d16"))).Row
  28.     ish.Range("b4") = Range("d" & hx).Offset(0, -3).Value
  29.     ish.Range("c4") = Range("d" & hx)

  31.     dl = ishe.Range("e:e").Find(Application.Min(ishe.Range("e2:e16"))).Row
  32.     ish.Range("b5") = Range("e" & dl).Offset(0, -4).Value
  33.     ish.Range("c5") = Range("e" & dl)

  35.     jsj = ishe.Range("f:f").Find(Application.Min(ishe.Range("f2:f16"))).Row
  36.     ish.Range("b6") = Range("f" & jsj).Offset(0, -5).Value
  37.     ish.Range("c6") = Range("f" & jsj)
  38. End Sub
糊啦啦。。
15楼
gofux		 gofux报到
22课题目.rar
16楼
ch_liu2000		 22试题答案.rar


浪迹天涯作业
17楼
冰淇林的冬天		 冰激凌的冬天
群号:30729794
22课作业.rar
18楼
gaoshuichang1		 22课题目.zip
在免费听课群的昵称:顺眼了
19楼
lb425319789		 只用到了FOR循环，For Each Next没有用上，不知该在什么地方用，目前代码测试顺利通过。


Sub 罗列各科目最后一名()
Dim rng As Range, firstaddress As String
Set rng = Worksheets(1).UsedRange
Worksheets(2).Range("a1:c1") = [{"科目","姓名","成绩"}]

Worksheets(1).Activate

m = 1  '该变量用于定义工作表2的行数
n = 0  '该变量用于工作表1查到每科目最少分单元格时定义对应的姓名单元格
For j = 2 To rng.Columns.Count '循环从表1的第二列到最后一列
    n = n + 1
    Set mymin = Worksheets(1).Range(Cells(2, j), Cells(rng.Rows.Count, j)) '定义表1的2行,J列到最后一行,J列的区域范围
    k = Application.WorksheetFunction.Min(mymin)  '该区域数值中查找最小值，赋给K

    With Range(Cells(2, j), Cells(rng.Rows.Count, j))  '对表1的2行,j列到最后一行,j列范围进行查找
    Set Min = .Find(k, LookAt:=xlWhole, LookIn:=xlValues) 'find方法
    If Not Min Is Nothing Then  '如果找到目标
       firstaddress = Min.Address '记录第一个找到的单元格地址
       Do    '继续查找，直到找到的单元格地址等于刚才记录的单元格地址时停止
         m = m + 1  '表2行数加1
         Worksheets(2).Cells(m, 3) = Min.Value  '将最少分数值放到表2的M行，3列
         Worksheets(2).Cells(m, 2) = Min.Offset(0, j - (j + n))    '将最少分数值的单元格，左移到对应的姓名单元格，值放到表2的M行，2列
         Worksheets(2).Cells(m, 1) = Cells(1, j) '表1的1行，J列即科目放到表2的M行1列
         Set Min = .FindNext(Min)   '查找下一个
         
       Loop While Min.Address <> firstaddress
    End If
    End With
Next
Worksheets(2).UsedRange.Borders.LineStyle = xlContinuous  '给工作表2使用区域添加边框

End Sub
20楼
静思雨
  1. Sub aaa()
  2. Dim c As Integer, r As Integer
  3. Dim col As Integer, rol As Integer
  4. Dim minv As Integer, a As Integer
  5. Dim rng As Range
  6. a = 2
  7. rol = Cells(Rows.Count, 1).End(xlUp).Row
  8. col = Cells(1, Columns.Count).End(xlToLeft).Column
  9. For c = 2 To col
  10. minv = Cells(2, c).Value
  11.   For r = 2 To rol
  12.         If minv > Cells(r, c) Then
  13.             minv = Cells(r, c).Value
  14.         End If
  15.   Next
  16.   For Each rng In Cells(1, c).Resize(rol, 1)
  17.    If rng.Value = minv Then
  18.    With Sheets("sheet2")
  19.    .Cells(a, 2) = Cells(rng.Row, 1).Value
  20.    .Cells(a, 3) = Cells(1, c)
  21.    .Cells(a, 4) = rng
  22.     a = a + 1
  23.     End With
  24.    End If
  25.   Next
  26. Next
  27. End Sub
21楼
杭州小菜02		 Sub aaa()
Dim c As Integer, r As Integer
Dim col As Integer, rol As Integer
Dim minv As Integer, a As Integer
Dim rng As Range
Application.ScreenUpdating = False
With Sheets("sheet2")
    .UsedRange.Clear
    .Range("a1:c1") = Array("科目", "姓名", "成绩")
    a = 2
rol = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
col = Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column
For c = 2 To col
    minv = Sheet1.Cells(2, c).Value
    For r = 2 To rol
        If minv > Sheet1.Cells(r, c) Then
            minv = Sheet1.Cells(r, c).Value
        End If
    Next
  For Each rng In Sheet1.Cells(1, c).Resize(rol, 1)
    If rng.Value = minv Then
        .Cells(a, 1) = Sheet1.Cells(1, c)
        .Cells(a, 2) = Sheet1.Cells(rng.Row, 1).Value
        .Cells(a, 3) = rng
        a = a + 1
    End If
  Next
Next
.Select
End With
Application.ScreenUpdating = True
End Sub
22楼
qing33670000		 群名：初学VBA
Sub aa()
    Dim icol%, irow%, c%, d%
    Sheets(2).Range("a1:c10").Clear
    Sheets(2).Range("a1:c1") = Array("科目", "姓名", "成绩")
    icol = Range("aa1").End(xlToLeft).Column
    irow = Range("a65536").End(xlUp).Row
    For c = 2 To icol
        For d = 2 To irow
            If Cells(d, c) = Application.Min(Range(Cells(2, c), Cells(irow, c))) Then
                Sheets(2).Range("a65536").End(xlUp).Offset(1, 0) = Cells(1, c)
                Sheets(2).Range("b65536").End(xlUp).Offset(1, 0) = Cells(d, 1)
                Sheets(2).Range("c65536").End(xlUp).Offset(1, 0) = Cells(d, c)
            End If
        Next
    Next
End Sub


Sub ab()
Dim icol%, irow%, c%, rg As Range
    Sheets(2).Range("a1:c10").Clear
    Sheets(2).Range("a1:c1") = Array("科目", "姓名", "成绩")
    icol = Range("aa1").End(xlToLeft).Column
    irow = Range("a65536").End(xlUp).Row
        For c = 2 To icol
            For Each rg In Range("a2:a" & irow).Offset(0, c - 1)
                If rg = Application.Min(Range("a2:a" & irow).Offset(0, c - 1)) Then
                Sheets(2).Range("a65536").End(xlUp).Offset(1, 0) = Cells(1, rg.Column)
                Sheets(2).Range("b65536").End(xlUp).Offset(1, 0) = Cells(rg.Row, 1)
                Sheets(2).Range("c65536").End(xlUp).Offset(1, 0) = Cells(rg.Row, rg.Column)
            End If
            Next
        Next
End Sub
23楼
wangxf9209		 交作业
22课题目、江苏-雪峰（1036638891）.zip
24楼
hzoptimax		 22课题目-●”莼黑色.rar
25楼
zql.8008		 群名along
  1. Sub test()
  2. Dim i%, k%, h%
  3. arr = Array("科目", "姓名", "分数")
  4. Sheets("sheet2").Range("a1").Resize(1, UBound(arr) + 1) = arr
  5. h = 2
  6.     For k = 3 To 7
  7.         For i = 2 To 16
  8.             If Cells(i, k - 1) = Application.WorksheetFunction.Min(Range(Cells(2, k - 1), Cells(16, k - 1))) Then
  9.                 Sheets("sheet2").Cells(h, 1) = Cells(1, k - 1)
  10.                 Sheets("sheet2").Cells(h, 2) = Cells(i, 1)
  11.                 Sheets("sheet2").Cells(h, 3) = Cells(i, k - 1)
  12.             h = h + 1
  13.             End If
  14.         Next
  15.     Next
  16. End Sub
26楼
398829134		 QQ昵称：Dumbledore
  1. Option Explicit

  3. Sub 罗列各科目最后一名()
  4.     Dim sht1 As Worksheet, sht2 As Worksheet, aRng As Range, tRng As Range, I As Long, endR As Long, lMin As Long
  5.     Set sht1 = Worksheets("sheet1")
  6.     Set sht2 = Worksheets("sheet2")
  7.     Application.ScreenUpdating = False
  8.     sht2.UsedRange.Clear
  9.     sht2.Range("A1").Value = "科目"
  10.     sht2.Range("b1").Value = "姓名"
  11.     sht2.Range("c1").Value = "成绩"
  12.     For I = 2 To 6
  13.         endR = sht1.Cells(Rows.Count, I).End(xlUp).Row
  14.         Set aRng = sht1.Range(sht1.Cells(2, I), sht1.Cells(endR, I))
  15.         lMin = Application.WorksheetFunction.Min(aRng)
  16.         For Each tRng In aRng
  17.             If tRng.Value = lMin Then
  18.                 sht2.Cells(sht2.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Value = sht1.Cells(1, I).Value
  19.                 sht2.Cells(sht2.Cells(Rows.Count, 2).End(xlUp).Row + 1, 2).Value = tRng.Offset(, -(I - 1)).Value
  20.                 sht2.Cells(sht2.Cells(Rows.Count, 3).End(xlUp).Row + 1, 3).Value = tRng.Value
  21.             End If
  22.         Next
  23.     Next
  24.     With sht2.UsedRange
  25.         .Borders(xlEdgeLeft).LineStyle = xlContinuous
  26.         .Borders(xlEdgeTop).LineStyle = xlContinuous
  27.         .Borders(xlEdgeBottom).LineStyle = xlContinuous
  28.         .Borders(xlEdgeRight).LineStyle = xlContinuous
  29.         .Borders(xlInsideVertical).LineStyle = xlContinuous
  30.         .Borders(xlInsideHorizontal).LineStyle = xlContinuous
  31.         .Columns.AutoFit
  32.     End With
  33.     Application.ScreenUpdating = True
  34. End Sub
27楼
twozisan		 ID==板桥 大刘
Sub 列各科目最后一名01()
Dim IROW As Integer '下
Dim ICOL As Integer '右
Dim myRange1 As Range
EEE = Range("IV2").End(xlToLeft).Column  '右
DDD = Range("b65536").End(xlUp).Row '下
mmm = 1
    For ICOL = 2 To EEE
      M = 100 '數據
     n = 0 'irow
        For IROW = 2 To DDD
               If Cells(IROW, ICOL).Value < M Then
                M = Cells(IROW, ICOL).Value
                n = IROW
                 Cells(IROW, ICOL).Select
              End If
       Next IROW
       mmm = mmm + 1
       Worksheets(2).Cells(mmm, 1) = Cells(1, ICOL)
       Worksheets(2).Cells(mmm, 3) = Cells(n, ICOL)
       Worksheets(2).Cells(mmm, 2) = Cells(n, 1)
    Next ICOL
End Sub
28楼
wangxf9209		 江苏-雪峰
22课第二波作业也在这里交吗？
题目二：
  1. Sub 汇总()
  2. Dim SHT As Worksheet, I%
  3. Range("A1") = "型号": Range("B1") = "库存"
  4. I = 2
  5. For Each SHT In Worksheets
  6.     If SHT.Name <> "汇总" Then
  7.         Cells(I, 1).Value = SHT.Name
  8.         Cells(I, 2) = SHT.Cells(Cells.Rows.Count, 3).End(3)
  9.         ActiveSheet.Hyperlinks.Add Anchor:=Cells(I, 1), Address:="", SubAddress:="'" & SHT.Name & "'!A1"  '超链接
  10.         I = I + 1
  11.     End If
  12. Next
  13. End Sub
题目三：
  1. Sub 提取不及格人员信息()
  2. Dim RNG As Range, RNG2 As Range, I%
  3. Range("J1") = "姓名": Range("K1") = "科目": Range("L1") = "成绩"
  4. 'Set RNG2 = Range("B2").Resize(Range("B2").CurrentRegion.Rows.Count - 1, Range("B2").CurrentRegion.Columns.Count - 1)
  5. Set RNG2 = Range("A1").CurrentRegion
  6.     For Each RNG In RNG2
  7.         If RNG < 60 Then
  8.         I = Cells(Rows.Count, 10).End(3).Row + 1
  9.         Cells(I, 10) = Cells(RNG.Row, 1)
  10.         Cells(I, 11) = Cells(1, RNG.Column)
  11.         Cells(I, 12) = RNG
  12.         End If
  13.     Next
  14. 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