白话Excel函数公式 Office易学宝微视频教程合集(Excel+Word+PPT)
笨办法学VBA(从入门到精通) 高效办公必会的Office实战技巧
财务总监的Excel私房课 网易云课堂-Excel数据透视表应用大全
Excel图表神技
查看: 384|回复: 8

练习4

[复制链接]
发表于 2015-8-13 11:27:24 | 显示全部楼层 |阅读模式
本帖最后由 临时户口 于 2015-9-7 20:49 编辑

本练习题用于加深对Range对象的认识,并锻炼修改宏代码的能力。表格左侧区域表中的第一行为标题行。
1)请删除F列所有非空单元格所在的整行(标题行除外,推荐用定位的方法解决),然后删除F列。
2)从A2单元格开始,重新向下填充自然数序列,一直填充到数据区域的最后一行。
以上每个小题设置10登攀。针对优秀代码及多种解法,本练习题合计最多给予10登攀的奖励。
本题由Leroy 老师为11122 班的练习出题,在此表示感谢


本题截至2015-8-20

练习四.rar

6.86 KB, 下载次数: 20

回复

使用道具 举报

发表于 2015-8-13 14:28:45 | 显示全部楼层
本帖最后由 q614081052 于 2015-8-20 17:11 编辑
  1. Sub 练习四方法1()
  2.     Dim arr, i&, k&, brr()
  3.     Application.ScreenUpdating = False
  4.     With Sheets("题目四")
  5.         arr = Range("a1:f" & Cells(Rows.Count, 1).End(3).Row)
  6.         .Range("a2:f" & UBound(arr)).ClearContents
  7.         For i = 2 To UBound(arr)
  8.             If arr(i, 6) = "" Then
  9.                 k = k + 1
  10.                 ReDim Preserve brr(1 To 5, 1 To k)
  11.                 brr(1, k) = k: brr(2, k) = arr(i, 2)
  12.                 brr(3, k) = arr(i, 3): brr(4, k) = arr(i, 4)
  13.                 brr(5, k) = arr(i, 5)
  14.             End If
  15.         Next
  16.         .Range("a2").Resize(UBound(brr, 2), UBound(brr)) = WorksheetFunction.Transpose(brr)
  17.     End With
  18.     Application.ScreenUpdating = True
  19. End Sub
  20. Sub 练习四方法2()
  21.     Dim i&, irow
  22.     Application.ScreenUpdating = False
  23.     With Sheets("题目四")
  24.         irow = .Cells(Rows.Count, 1).End(3).Row
  25.         For i = 2 To irow
  26.             If .Cells(i, 6) <> "" Then
  27.                 .Rows(i).Delete
  28.             End If
  29.         Next
  30.         Columns(6).Delete
  31.     End With
  32.     Application.ScreenUpdating = True
  33. End Sub
复制代码

点评

方法2 不对 方法1 写代码不规范用:  发表于 2015-9-7 20:23

评分

参与人数 1登攀 +10 收起 理由
临时户口 + 10

查看全部评分

回复 支持 反对

使用道具 举报

发表于 2015-8-14 12:06:51 | 显示全部楼层
本帖最后由 夏寂雨透 于 2015-8-14 22:00 编辑

小白暂时只会用录宏的办法来解决。
  1. Sub test()
  2. Range("F2:F111").Select
  3. Selection.SpecialCells(xlCellTypeBlanks).Select
  4. Selection.EntireRow.Delete
  5. Columns("F:F").Select
  6. Selection.Delete Shift:=xlToLeft
  7. Range("A2").Select
  8. ActiveCell.FormulaR1C1 = "1"
  9. Range("A2").Select
  10. Selection.AutoFill Destination:=Range("A2:A8"), Type:=xlFillSeries
  11. Range("A2:A8").Select
  12. End Sub
复制代码

点评

题意弄反了  发表于 2015-9-7 20:26

评分

参与人数 1登攀 +10 收起 理由
临时户口 + 10

查看全部评分

回复 支持 反对

使用道具 举报

发表于 2015-8-19 17:05:26 | 显示全部楼层
方法一:
  1. Sub 删除填充1()
  2.     Dim i As Long, irow As Long, j As Long, k As Long
  3.     Dim arr()
  4.     Application.ScreenUpdating = False
  5.     i = Sheets("题目四").Rows.Count
  6.     irow = Sheets("题目四").Range("a" & i).End(xlUp).Row
  7.     For j = 3 To irow
  8.         If Len(Sheets("题目四").Cells(j, "f")) > 0 Then
  9.             Cells(j, "f").EntireRow.Delete
  10.         End If
  11.     Next
  12.     Columns("f").Delete
  13.     irow = (Sheets("题目四").Range("a" & i).End(xlUp).Row) - 1
  14.     ReDim arr(1 To irow)
  15.     For k = 1 To irow
  16.         arr(k) = k
  17.     Next
  18.     Range("a2").Resize(irow) = Application.Transpose(arr)
  19.     Application.ScreenUpdating = True
  20. End Sub
复制代码
方法二:
  1. Sub 删除填充2()
  2.     Dim i As Long, irow As Long, j As Long, k As Long
  3.     Dim rng As Range
  4.     Dim arr()
  5.     Application.ScreenUpdating = False
  6.     i = Sheets("题目四").Rows.Count
  7.     irow = Sheets("题目四").Range("a" & i).End(xlUp).Row
  8.     For j = 3 To irow
  9.         If Sheets("题目四").Range("f" & j) <> "" Then
  10.             If rng Is Nothing Then
  11.                 Set rng = Sheets("题目四").Rows(j)
  12.             Else
  13.                 Set rng = Union(rng, Sheets("题目四").Rows(j))
  14.             End If
  15.         End If
  16.     Next j
  17.     If rng Is Nothing Then End
  18.     rng.Delete
  19.     Columns("f").Delete
  20.     irow = (Sheets("题目四").Range("a" & i).End(xlUp).Row) - 1
  21.     ReDim arr(1 To irow)
  22.     For k = 1 To irow
  23.         arr(k) = k
  24.     Next
  25.     Range("a2").Resize(irow) = Application.Transpose(arr)
  26.     Application.ScreenUpdating = True
  27. End Sub
复制代码


点评

方法一代码不正确  发表于 2015-9-7 20:46
方法二不错用了union  发表于 2015-9-7 20:45

评分

参与人数 1登攀 +15 收起 理由
临时户口 + 15

查看全部评分

回复 支持 反对

使用道具 举报

发表于 2015-8-20 19:11:39 | 显示全部楼层
本帖最后由 lilyren 于 2015-8-20 19:17 编辑
  1. Sub 删除非空单元格()
  2. '
  3. ' Macro1 Macro
  4. '

  5. '
  6.     Range("F2:F111").SpecialCells(xlCellTypeConstants).EntireRow.Delete
  7.     Columns("F:F").Delete
  8.     Range("a2") = 1
  9.     Range("a3") = 2
  10.     Dim i As Integer
  11.     i = Range("a1000").End(xlUp).Row
  12.     Range("A2:A3").AutoFill Destination:=Range("A2:A" & i), Type:=xlFillDefault
  13. End Sub
复制代码
  1. Sub 重新排序2()
  2. Dim i As Integer, b As Integer, c As Integer
  3. For i = 2 To 111
  4.     If Range("F" & i).Value <> "" Then
  5.         Range("F" & i).EntireRow.Delete
  6.     End If
  7. Next
  8. Columns("F:F").Delete
  9. b = Range("a10000").End(xlUp).Row
  10. For c = 2 To b
  11.     Range("a" & c) = c - 1
  12. Next
  13. End Sub
复制代码


评分

参与人数 1登攀 +15 收起 理由
临时户口 + 15

查看全部评分

回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 入学

本版积分规则

快速回复 返回顶部 返回列表