12月19/20日 财务会计玩转Excel 300集Office 2010微视频教程
12月22/23日 7天Excel脱白 高效办公必会的Office实战技巧
11月28日 Excel图表之美 网易云课堂-Excel数据透视表应用大全
Excel数据处理与分析实战技巧第1季
查看: 318|回复: 13

零基础学ExcelVBA 第十一期 第十三课时作业贴

[复制链接]
发表于 2017-8-7 22:10:43 | 显示全部楼层 |阅读模式
本帖最后由 开心妙妙 于 2017-9-6 19:50 编辑

交作业的要求:

1、不需要附件,只需贴代码,说明你做的是哪道题
2、贴上的代码都需要缩进,并且关键语句要有注释
3、请在添加代码文字,那里添加代码,这样代码在楼层中显得赏心悦目。不知道怎样操作的小伙伴,可以参照看动画
113058c5vzhlg55gq16qpg.gif
回复

使用道具 举报

发表于 2017-8-8 13:46:09 | 显示全部楼层
Sub 销售人员分表()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Dim sht As Worksheet, sht1 As Worksheet, i As Long, str As String
    Set sht = Worksheets.Add(after:=Sheets("销售表"))
        sht.Name = "名字检索"
        Sheets("销售表").[a1].CurrentRegion.Columns(4).Copy Sheets("名字检索").Columns(1)
        Worksheets("名字检索").Range("$A$1:$A$204").RemoveDuplicates Columns:=1, Header:=xlYes    '去掉重复内容
'        Worksheets("销售表").Range("$D$1:$D$204").AutoFilter
        i = 2

        Do Until ThisWorkbook.Sheets("名字检索").Range("a" & i) = ""

            ThisWorkbook.Sheets("销售表").Range("$D$1:$D$204").AutoFilter Field:=1, _
                    Criteria1:=ThisWorkbook.Sheets("名字检索").Range("a" & i)
            Set sht1 = ThisWorkbook.Sheets.Add    '(after:=Sheets("名字检索"))
                sht1.Name = ThisWorkbook.Sheets("名字检索").Range("a" & i)
            ThisWorkbook.Sheets("销售表").Range("a1").CurrentRegion.Copy sht1.Range("a1")
            sht1.Copy
            str = ActiveSheet.Name
            ActiveWorkbook.SaveAs str & ".xlsx"
            ThisWorkbook.ActiveSheet.Delete
            i = i + 1
        Loop

    ThisWorkbook.Sheets("名字检索").Delete
    ThisWorkbook.Sheets("销售表").Columns("D:D").AutoFilter
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub

Function mylookup(lookupvalue, area As Range, col As Long)
    Dim i As Long
    i = area.Find(lookupvalue).Column - col
  mylookup = Cells(area.Find(lookupvalue).Row, i)
End Function

Sub instr练习()
    Dim str As String, num As Long, cot As Long
    str = "某老病人一直咳嗽不止,有天他去看医生。医生检查后问他:您20岁的时候有咳嗽的毛病吗?病人 " & _
  "回答,不咳嗽。医生又问,那么你30岁时咳嗽过吗?病人回答没咳嗽过。医生再问,你40岁的时候" & _
  "咳嗽吗?病人回答不咳嗽。医生忍着性子问,50岁时候呢?咳嗽吗?病人说,不咳嗽,不咳嗽。" & _
  "医生生气的说,那你现在还不咳嗽,还想什么时候咳嗽呢?"
   num = 1
   Do Until InStr(num, str, "咳嗽", 1) = 0
   num = InStr(num + 2, str, "咳嗽", 1) + 2
   cot = cot + 1
   Loop
   Debug.Print cot

End Sub

回复 支持 反对

使用道具 举报

发表于 2017-8-8 14:10:59 | 显示全部楼层
本帖最后由 cynthiashi 于 2017-8-10 09:53 编辑

Sub answer807_作业1()

    Dim i&, rng As Range
    Dim sht As Worksheet, shtI As Worksheet, shtD As Worksheet
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set sht = Worksheets.Add(after:=Worksheets("销售表"))
    sht.Name = "销售人员名单"
    Worksheets("销售表").[a1].CurrentRegion.Columns(4).Copy sht.[a1]
    sht.[a1].CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
    For i = 2 To sht.[a1].CurrentRegion.Rows.Count
        Set rng = sht.Range("a" & i)
        Set shtI = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        shtI.Name = rng
        Worksheets("销售表").[a1].CurrentRegion.AutoFilter Field:=4, Criteria1:=rng
        Worksheets("销售表").[a1].CurrentRegion.SpecialCells(xlCellTypeVisible).Copy shtI.[a1]
        shtI.Copy
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\人员\" & shtI.Name & ".xlsx"
        ActiveWorkbook.Close True
    Next
    Worksheets("销售表").[a1].CurrentRegion.AutoFilter
    For Each shtD In Worksheets
        If shtD.Name <> "销售表" Then shtD.Delete
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
        
End Sub



Function mylookup(lookupvalue, area As Range, col As Long)
   
    Dim rng As Range
    Set rng = area.Find(lookupvalue)
    If Not rng Is Nothing Then mylookup = rng.Offset(0, col)

End Function



Sub 咳嗽求解()
    Dim str As String, i As Long, count As Long
    str = "某老病人一直咳嗽不止,有天他去看医生。医生检查后问他:您20岁的时候有咳嗽的毛病吗?病人回答,不咳嗽。医生又问,那么你30岁时咳嗽过吗?病人回答没咳嗽过。医生再问,你40岁的时候咳嗽吗?病人回答不咳嗽。医生忍着性子问,50岁时候呢?咳嗽吗?病人说,不咳嗽,不咳嗽。医生生气的说,那你现在还不咳嗽,还想什么时候咳嗽呢?"
    i = 1
    Do While InStr(i, str, "咳嗽") > 0
        i = InStr(i, str, "咳嗽") + 2
        count = count + 1
    Loop
    MsgBox "一共出现了" & count & "咳嗽"
End Sub



Sub AutocopyTemplate()

     Dim i&, j&, num&
     Dim name As String
     Dim sht As Worksheet, rng As Range
     Application.DisplayAlerts = False
     name = Worksheets(Worksheets.Count).name
     i = Left(name, InStr(name, "年") - 1)
     j = Mid(name, InStr(name, "年") + 1, InStr(name, "月") - InStr(name, "年") - 1)
     If j < 12 Then
         j = j + 1
     Else
         i = i + 1
         j = 1
     End If
     num = Worksheets.Count
     Worksheets(num).Copy after:=Worksheets(num)
     Set sht = Worksheets(num + 1)
     sht.name = i & "年" & j & "月"
     Set rng = Worksheets(sht.name).Range("a2").Offset(1, 1).Resize(2, 4)
     rng.ClearContents
     ActiveSheet.Shapes.Range(Array("Button 1")).Select OnAction = "AutocopyTemplate"
     Application.DisplayAlerts = True
     
End Sub



回复 支持 反对

使用道具 举报

发表于 2017-8-8 18:27:39 | 显示全部楼层
  1. Sub 作业1()
  2. Dim h As Worksheet, i As Long, m As String, d As String, s As Worksheet
  3.     Application.DisplayAlerts = False
  4.     Application.ScreenUpdating = False
  5.     Worksheets.Add After:=Worksheets("销售表")
  6.     ActiveSheet.Name = "标的"
  7.     With Worksheets("标的")
  8.     Worksheets("销售表").Range("d:d").Copy .[a1]
  9.     .Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
  10.             For i = 2 To .[a1].CurrentRegion.Count
  11.                 If .Range("a" & i) <> "" Then
  12.                 Worksheets.Add After:=Worksheets(Worksheets.Count)
  13.                 m = .Range("a" & i)
  14.                 ActiveSheet.Name = m
  15.                 Worksheets("销售表").Range("a:h").AutoFilter Field:=4, Criteria1:=m
  16.                 Worksheets("销售表").Range("a:h").Copy Worksheets(m).[a1]
  17.                 End If
  18.           Next
  19.     End With
  20.     For Each h In Worksheets
  21.     If h.Name <> "销售表" And h.Name <> "标的" Then
  22.     h.Copy
  23.     d = ActiveWorkbook.Worksheets(1).[d2]
  24.     ActiveWorkbook.SaveAs Filename:="D:\人员" & d & ".xlsx"
  25.     ActiveWorkbook.Close False
  26.     End If
  27.     Next
  28.     ThisWorkbook.Close
  29.     Application.ScreenUpdating = True
  30.     Application.DisplayAlerts = True
  31. End Sub

  32. Function mylookup(lookupvalue, area As Range, col As Long)
  33.     Dim find As Range
  34.     Set find = area.find(lookupvalue, lookat:=xlWhole)
  35.     mylookup = Cells(find.Row, col)
  36. End Function

  37. Sub 查找()
  38. Dim rng As Range, s As String, i As Integer, w As Integer
  39.      Set rng = Worksheets("sheet1").[a1]
  40.      s = "咳嗽"
  41.      i = 1
  42.         Do Until i >= Len(Worksheets("sheet1").[a1]) - 2
  43.         i = InStr(i, rng, s, 1)
  44.         i = i + 1
  45.         w = w + 1
  46.         Loop
  47.     MsgBox "一共出现了" & w & "个咳嗽"
  48. End Sub


复制代码
回复 支持 反对

使用道具 举报

发表于 2017-8-9 00:58:47 | 显示全部楼层
  1. Option Explicit

  2. '按销售表销售人员分表,分别存储成人名的工作簿存到人员子目录下。
  3. Sub 人名工作簿()
  4.     Dim i&, j&, n&, rng As Range, wb As Workbook, sth As Worksheet
  5.     Dim str As String
  6.     Application.ScreenUpdating = False
  7.     Application.DisplayAlerts = False
  8.    
  9.    
  10.     Worksheets.Add after:=Sheets(Sheets.Count)    '生成index辅助表
  11.     Worksheets("销售表").Activate                 '将销售表设定为活动电子表
  12.     For i = 1 To [a1].CurrentRegion.Rows.Count      '通过循环生成不重复的人名序列
  13.         For j = 1 To [a1].CurrentRegion.Rows.Count
  14.             If Sheets(2).Cells(j, 1) = "" Then
  15.                Sheets(2).Cells(j, 1) = Cells(i, "d")
  16.                 Exit For
  17.             ElseIf Sheets(2).Cells(j, 1) = Cells(i, "d") Then
  18.                 Exit For
  19.             End If
  20.         Next

  21.     Next

  22.     For i = 2 To Sheets(2).[a1].CurrentRegion.Rows.Count '通过index辅助表人名对销售表进行筛选

  23.         Worksheets.Add after:=Sheets(Sheets.Count) '在所有工作表后生成一个新表
  24.         Worksheets("销售表").Activate   '设定销售表为当前活动电子表
  25.         str = Sheets(2).Cells(i, 1)     ''通过index辅助表人名对销售表进行筛选


  26.         Range("a1").CurrentRegion.AutoFilter Field:=4, Criteria1:=str    '以str对表1第四列筛选

  27.         Range("a1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy (Sheets(Sheets.Count).[a1])
  28.                                                                     '筛选后复制可见单元格到新表里
  29.         Sheets(Sheets.Count).Name = str     '将新电子表命名为str(人名)
  30.     Next
  31.    
  32.    
  33.     For Each sth In Worksheets           '将筛选的结果生成的电子表COPY生成各人员相关的单独电子簿,
  34.                                         '并保存在默认文件夹下的人员文件夹内.
  35.         If sth.Name <> "销售表" And sth.Name <> Worksheets(2).Name Then
  36.             sth.Copy
  37.             str = ThisWorkbook.Path & "\人员" & sth.Name 'fullname:默认路径加上电子表名(人名)
  38.             ActiveWorkbook.SaveAs str
  39.             ActiveWorkbook.Close True           '关闭并保存
  40.             
  41.         End If
  42.     Next
  43.    
  44.     For Each sth In Worksheets          '删除添加的辅助电子表
  45.         If sth.Name <> "销售表" Then
  46.             sth.Delete
  47.         End If
  48.     Next
  49.    
  50.     Range("a1").CurrentRegion.AutoFilter Field:=4   '恢复筛选前表格正常状态
  51.    
  52.     Application.DisplayAlerts = True
  53.     Application.ScreenUpdating = True
  54.    
  55. End Sub
  56. 'myvlookup 函数
  57. 'vlookup(找谁,在哪找,返回谁)
  58. 'Sub functiondemo()
  59. '    MsgBox mylookup("王心刚", [a1].CurrentRegion, 2)
  60. 'End Sub

  61. Function mylookup(lookupvalue, area As Range, col As Long)
  62.    
  63.     mylookup = area.Find(lookupvalue).Offset(, col)

  64. End Function

  65. 'Instr 练习:instr(起始位置,母串,子串)
  66. '某老病人一直咳嗽不止,有天他去看医生。医生检查后问他:您20岁的时候有咳嗽的毛病吗?病人
  67. '回答,不咳嗽。医生又问,那么你30岁时咳嗽过吗?病人回答没咳嗽过。医生再问,你40岁的时候
  68. '咳嗽吗?病人回答不咳嗽。医生忍着性子问,50岁时候呢?咳嗽吗?病人说,不咳嗽,不咳嗽。
  69. '医生生气的说,那你现在还不咳嗽,还想什么时候咳嗽呢?

  70. '编程解答一共出现了多少个咳嗽

  71. Sub 咳嗽()
  72.     Dim i&, j&, str$
  73.     str = "某老病人一直咳嗽不止,有天他去看医生。医生检查后问他:您20岁的时候有咳嗽的毛病吗?病人回答,不咳嗽。医生又问,那么你30岁时咳嗽过吗?病人回答没咳嗽过。医生再问,你40岁的时候咳嗽吗?病人回答不咳嗽。医生忍着性子问,50岁时候呢?咳嗽吗?病人说,不咳嗽,不咳嗽。医生生气的说,那你现在还不咳嗽,还想什么时候咳嗽呢?"

  74.     Do
  75.         i = i + 1
  76.         j = InStr(j + 2, str, "咳嗽")
  77.    
  78.     Loop Until j = 0
  79.     i = i - 1
  80.     MsgBox "共有" & i & "个咳嗽"
  81.    
  82. End Sub
复制代码


回复 支持 反对

使用道具 举报

发表于 2017-8-9 18:35:30 | 显示全部楼层
本帖最后由 tiantian950200 于 2017-8-9 22:31 编辑
  1. Sub 作业一销售人员分拆()
  2.     Dim i As Long
  3.     Dim 名字 As String
  4.    
  5.     Application.DisplayAlerts = False
  6.     Application.ScreenUpdating = False
  7.    
  8.     Worksheets("销售表").Activate
  9.     Worksheets.Add After:=Worksheets(Worksheets.Count) '最后添加工作表
  10.     Worksheets(Worksheets.Count).Name = "人员清单" '改名
  11.     Worksheets("销售表").Range("D:D").Copy Worksheets("人员清单").Range("A1") '复制人员姓名
  12.     Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes '去重
  13.    
  14.     For i = 2 To Range("A1").CurrentRegion.Rows.Count '循环姓名行数
  15.         名字 = Worksheets("人员清单").Cells(i, 1) '提取姓名赋值到变量
  16.         Worksheets.Add After:=Worksheets(Worksheets.Count) '最后添加工作表
  17.         Worksheets(Worksheets.Count).Name = 名字 '改名
  18.         Worksheets("销售表").Range("1:1").AutoFilter Field:=4, Criteria1:=名字 '自动筛选
  19.         Worksheets("销售表").Range("A1").CurrentRegion.Copy Worksheets(名字).Range("A1") '复制到最后工作表
  20.         Worksheets(名字).Copy '无路径复制,新增新的工作簿
  21.         ActiveWorkbook.SaveAs ThisWorkbook.Path & "\13课人员分解" & 名字 & ".xlsx" '储存
  22.         ActiveWorkbook.Close False '关闭新的工作簿
  23.         Worksheets(Worksheets.Count).Delete '删除最后一个工作表
  24.     Next
  25.         Worksheets("人员清单").Delete '删除工作表
  26.         Worksheets("销售表").Range("1:1").AutoFilter , 取消自动筛选

  27.     Application.ScreenUpdating = True
  28.     Application.DisplayAlerts = True
  29. End Sub
复制代码
  1. Sub functiondemo()
  2.     MsgBox mylookup("王心刚", [A1].CurrentRegion, -2)
  3. End Sub

  4. Function mylookup(lookupvalue, area As Range, col As Long)
  5.     mylookup = area.Find(lookupvalue).Offset(0, col)
  6. End Function
复制代码
  1. Sub instr练习()
  2.     Dim 故事 As String
  3.     Dim 目标位 As Long, 累计 As Long
  4.    
  5.     故事 = "某老病人一直咳嗽不止,有天他去看医生。医生检查后问他:您20岁的时候有咳嗽的毛病" _
  6.                   & "吗?病人回答,不咳嗽。医生又问,那么你30岁时咳嗽过吗?病人回答没咳嗽过。" _
  7.                   & "医生再问,你40岁的时候咳嗽吗?病人回答不咳嗽。医生忍着性子问,50岁时候" _
  8.                   & "呢?咳嗽吗?病人说,不咳嗽,不咳嗽。医生生气的说,那你现在还不咳嗽,还想什么时候咳嗽呢?"
  9.     目标位 = 1
  10.     Do
  11.        If InStr(目标位, 故事, "咳嗽") <> 0 Then
  12.             目标位 = InStr(目标位, 故事, "咳嗽") + 2
  13.             累计 = 累计 + 1
  14.         Else
  15.             Exit Do
  16.         End If
  17.     Loop
  18.     MsgBox "故事里累计出现了" & 累计 & "次咳嗽"
  19. End Sub
复制代码
  1. Sub 自动复制表和日期()
  2.     Dim 月份

  3.     月份 = DateAdd("m", 1, Worksheets(1).Name) '月份=第1个表+1月
  4.     Worksheets(1).Copy before:=Sheets(1) '复制新表在最前面
  5.     月份 = Format(月份, "yyyy年m月") '调整格式日期
  6.     Worksheets(1).Name = 月份 '重命名
  7.     Worksheets(1).Range("A2").CurrentRegion.SpecialCells(xlCellTypeConstants, 1).ClearContents
  8.     '清除有常量数字的单元格
  9. End Sub
复制代码

回复 支持 反对

使用道具 举报

发表于 2017-8-9 19:14:44 | 显示全部楼层
  1. '按销售表销售人员分表,分别存储成人名的工作簿存到人员子目录下。
  2. Sub CNN第十三课时作业题1分表()
  3. '    '定义变量。我是分割线===========================
  4.     Dim FS As Object
  5.     Dim F As Object
  6.     Dim wb As Workbook
  7.     Dim sht As Worksheet
  8.     Dim area As RANGE
  9.     Dim arng As RANGE
  10.     Dim splitname As String
  11.     Dim spath As String
  12.     Dim sprng As RANGE
  13.     Dim spfor As RANGE
  14.     Dim af As RANGE
  15.     Dim i As Long
  16.     Dim scol As Long
  17.     '关闭警示
  18.     Application.DisplayAlerts = False
  19.     'splitname变量设定分表的标准,spath变量设定分表的路径,可以更改
  20.     splitname = "销售人员"
  21.     spath = "人员"
  22.     '如果路径存在,且有文件,就删除文件并创建,否则就跳过;如果不存在就创建
  23.     If Dir(ThisWorkbook.Path & "" & spath, vbDirectory) = spath Then
  24.         If Dir(ThisWorkbook.Path & "" & spath & "" & "*.*") <> "" Then
  25.             Kill ThisWorkbook.Path & "" & spath & "" & "*.*"
  26.             RmDir ThisWorkbook.Path & "" & spath
  27.             MkDir ThisWorkbook.Path & "" & spath
  28.         End If
  29.     Else
  30.         MkDir ThisWorkbook.Path & "" & spath
  31.     End If
  32. '    '按照split赋值标准建立同名工作表,并对其中数据去重。我是分割线===========================
  33.     '如果已有同名工作表,先删除,防止出现错误。
  34.     For Each sht In Worksheets
  35.         If sht.Name <> "销售表" Then
  36.             sht.Delete
  37.         End If
  38.     Next
  39.     '设置销售表区域,符合条件区域,符合条件列号
  40.     '把符合条件区域筛选复制到新表,并按分表标准命名
  41.     Set area = ThisWorkbook.Worksheets("销售表").RANGE("A1").CurrentRegion
  42.     Set arng = area.Find(splitname)
  43.     scol = arng.Column
  44.     arng.Resize(area.Rows.Count - 1, 1).Copy
  45.     Worksheets.Add(before:=Worksheets("销售表")).Name = splitname
  46.     ActiveSheet.Paste
  47.     ActiveSheet.RANGE("a1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
  48. '    '按照split表中数据依次将销售表中数据复制到新工作表并同名命名。我是分割线==============
  49.     '将按照分表标准,将符合条件的新表数据赋值给sprng
  50.     Set sprng = ActiveSheet.RANGE("a1").CurrentRegion
  51.     '如果存在不符合前两步操作外的工作表,删除。
  52.     For Each sht In Worksheets
  53.         If sht.Name <> splitname And sht.Name <> "销售表" Then
  54.             sht.Delete
  55.         End If
  56.     Next
  57.     '按分表数据遍历,并将符合条件的数据筛选复制到新表且同名命名。
  58.     For Each spfor In sprng.Offset(1, 0).Resize(sprng.Rows.Count - 1, 1)
  59.         Debug.Print spfor
  60.         area.AutoFilter
  61.         area.AutoFilter Field:=scol, Criteria1:=spfor
  62.         area.Copy
  63.         Worksheets.Add(after:=Worksheets("销售表")).Name = spfor
  64.         ActiveSheet.Paste
  65.     '新建工作簿,并按照筛选出的新表复制命名同名工作表并另存为同名文件。
  66.         Set wb = Workbooks.Add
  67.         wb.Worksheets("sheet1").Paste
  68.         wb.Worksheets("sheet1").Name = spfor
  69.         wb.SaveAs ThisWorkbook.Path & "" & spath & "" & spfor & ".xlsx"
  70.         wb.Close True
  71.     Next
  72.     '筛选复原,警示复原
  73.     area.AutoFilter
  74.     Application.DisplayAlerts = True
  75. End Sub
复制代码
  1. Function CNNVlookup(lookupvalue, area As String, col As Long)
  2.     Dim rng As RANGE
  3.     Set rng = RANGE(area).Find(lookupvalue)
  4.     If Not rng Is Nothing Then
  5.         CNNVlookup = rng.Offset(0, col).Resize(1, 1)
  6.     Else
  7.         CNNVlookup = "没有找到查找对象!"
  8.     End If
  9. End Function
复制代码
  1. Sub CNN第十三课时作业题3咳嗽统计()
  2.     Dim 次数 As Long
  3.     Dim i As Long
  4.     Dim 笑话 As String
  5.     笑话 = "某老病人一直咳嗽不止,有天他去看医生。医生检查后问他:您20岁的时候有咳嗽的毛病吗? " & _
  6.     "病人回答,不咳嗽。医生又问,那么你30岁时咳嗽过吗?病人回答没咳嗽过。医生再问,你40岁的时候 " & _
  7.     "咳嗽吗?病人回答不咳嗽。医生忍着性子问,50岁时候呢?咳嗽吗?病人说,不咳嗽,不咳嗽。" & _
  8.     "医生生气的说,那你现在还不咳嗽,还想什么时候咳嗽呢?"
  9.     i = InStr(笑话, "咳嗽")
  10.     Do Until i = 1
  11.         i = InStr(笑话, "咳嗽")
  12.         Debug.Print i
  13.         i = i + 1
  14.         笑话 = Right(笑话, Len(笑话) - i)
  15.         次数 = 次数 + 1
  16.     Loop
  17.     Debug.Print "咳嗽出现的次数是:" & 次数 - 1
  18. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2017-8-9 19:44:16 | 显示全部楼层
  1. '作业1
  2. Sub splitandsheets()
  3.     Dim r As Long, rng As Range, firstadd As String, sht As Worksheet
  4.     Application.ScreenUpdating = False
  5.     Application.DisplayAlerts = False
  6.     For Each sht In Sheets
  7.         If sht.Name <> "销售表" Then
  8.             sht.Delete
  9.         End If
  10.     Next
  11.     Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "personnel"
  12.     Sheets(1).Columns("d:d").Copy Worksheets("personnel").Range("a1")
  13.     Worksheets("personnel").Columns("a:a").RemoveDuplicates 1
  14.     For r = 2 To 5
  15.         Worksheets.Add(after:=Sheets(Sheets.Count)).Name = Worksheets("personnel").Cells(r, 1).Value
  16.         Sheets(1).Range("a1").CurrentRegion.Rows(1).Copy ActiveSheet.Range("a1")
  17.        Set rng = Sheets(1).Range("a1").CurrentRegion.Find(Sheets("personnel").Cells(r, 1).Value)
  18.        If Not rng Is Nothing Then
  19.             firstadd = rng.Address
  20.             Do
  21.                 Set rng = Sheets(1).Range("a1").CurrentRegion.FindNext(rng)
  22.                 rng.EntireRow.Copy ActiveSheet.Cells(Range("a1048576").End(xlUp).Row + 1, 1)
  23.             Loop Until rng.Address = firstadd
  24.        End If
  25.        ActiveSheet.Move
  26.        ActiveSheet.SaveAs ThisWorkbook.Path & "\人员" & ActiveSheet.Name & ".xlsx"
  27.        ActiveWorkbook.Close False
  28.     Next
  29.     Worksheets("personnel").Delete
  30.     Application.DisplayAlerts = True
  31.     Application.ScreenUpdating = True
  32. End Sub

  33. ‘作业2
  34. Function mylookup(lookup, area As Range, col As Long)
  35.     Dim rng As Range, firstadd As String
  36.     Set rng = area.Find(lookup)
  37.     If Not rng Is Nothing Then
  38.        mylookup = Cells(rng.Row, col).Value
  39.     Else
  40.         mylookup = "没找到王心刚"
  41.     End If
  42. End Function

  43. ‘作业3
  44. Sub statictics()
  45.     Dim site As Long, count As Long
  46.     site = InStr(Cells(1, 1).Value, "咳")
  47.     If site > 0 Then
  48.         Do
  49.             site = InStr(site + 2, Cells(1, 1).Value, "咳")
  50.             count = count + 1
  51.         Loop Until site = 0
  52.     End If
  53.     MsgBox "一共出现了" & count & "个咳嗽"
  54.    
  55. End Sub


复制代码
回复 支持 反对

使用道具 举报

发表于 2017-8-10 23:37:51 | 显示全部楼层
  1. Option Explicit
  2. '作业1
  3. '按销售表销售人员分表,分别存储成人名的工作簿存到人员子目录下。
  4. Sub 工作表拆分()
  5.     Application.DisplayAlerts = False
  6.     Application.ScreenUpdating = False
  7.     Dim i As Long, sht As Worksheet
  8.     Worksheets.Add after:=Worksheets("销售表")
  9.     ActiveSheet.Name = "去重"                                                                          '新建一张表命名为“去重”
  10.     Worksheets("销售表").Range("d2:d" & Worksheets("销售表").Range("a1").CurrentRegion.Rows.Count).Copy
  11.     Worksheets("去重").Range("a1").PasteSpecial Paste:=xlPasteValues                                   '将D列销售人员的名单复制粘贴值到去重表
  12.     Worksheets("去重").Range("a1:a" & Worksheets("销售表").Range("a1").CurrentRegion.Rows.Count).RemoveDuplicates Columns:=1 '去重
  13.     For i = 1 To Worksheets("去重").Range("a1").CurrentRegion.Rows.Count
  14.         Worksheets.Add after:=Worksheets(Worksheets.Count)
  15.         ActiveSheet.Name = Worksheets("去重").Range("a" & i)                                            '新建一张表,命名为去重后第一个销售人员的名字
  16.         Worksheets("销售表").Range("a1").CurrentRegion.AutoFilter field:=4, Criteria1:=Worksheets("去重").Range("a" & i)     '筛选查找
  17.         Worksheets("销售表").Range("a1").CurrentRegion.Copy Worksheets(Worksheets("去重").Range("a" & i).Value).Range("a1")  '将查找结果复制到对应表格
  18.         ActiveSheet.Range("a1").CurrentRegion.AutoFilter
  19.         ActiveSheet.Range("a1").CurrentRegion.AutoFilter    '去掉结果表的筛选
  20.         ActiveSheet.Copy                                    '复制结果表到新工作簿
  21.         ActiveWorkbook.SaveAs "D:\Documents\Tencent Files\零基础学VBA第13课\人员" & ThisWorkbook.Worksheets("去重").Range("a" & i) & ".xlsx"   '保存新工作簿,并命名为对应的销售人员名字
  22.         ActiveWorkbook.Close True           '关闭保存好的工作簿
  23.     Next
  24.     Worksheets("销售表").Range("a1").CurrentRegion.AutoFilter           '去掉原销售表的筛选
  25.     For Each sht In Worksheets                                          '删掉多余的表
  26.         If sht.Name <> "销售表" Then
  27.             sht.Delete
  28.         End If
  29.     Next
  30.     Application.DisplayAlerts = True
  31.     Application.ScreenUpdating = True
  32. End Sub



  33. ’作业2
  34. Sub functiondemo()
  35.     MsgBox mylookup("王心刚", [a1].CurrentRegion, 7)
  36. End Sub

  37. Function mylookup(lookupvalue, area As Range, col As Long)
  38.     mylookup = area.Find(lookupvalue).Offset(0, col - 4)
  39. End Function


  40. '作业3
  41. Sub instr练习()
  42.     Dim str As String, i As Long, j As Long
  43.     str = "某老病人一直咳嗽不止,有天他去看医生。医生检查后问他:您20岁的时候有咳嗽的毛病吗?病人回答,不咳嗽。医生又问,那么你30岁时咳嗽过吗?病人回答没咳嗽过。医生再问,你40岁的时候咳嗽吗?病人回答不咳嗽。医生忍着性子问,50岁时候呢?咳嗽吗?病人说,不咳嗽,不咳嗽。医生生气的说,那你现在还不咳嗽,还想什么时候咳嗽呢?"
  44.     i = InStr(str, "咳嗽")
  45.         Do Until i + 2 > Len(str) Or i = 0
  46.             j = j + 1
  47.             i = InStr(i + 2, str, "咳嗽")
  48.         Loop
  49.     Debug.Print "一共出现了" & j&; "个咳嗽"
  50. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2017-8-11 14:34:23 | 显示全部楼层
补一下思考题的答案哈

  1. Option Explicit
  2. '工作表复制示例(自动复制模板、生成日期)

  3. Sub 自动复制模板生成日期()
  4.     Call 指定宏             '主过程,用于指定宏
  5. End Sub

  6. Sub 指定宏()
  7.     ActiveSheet.Shapes.Range(Array("Button 1")).Select
  8.     Selection.OnAction = "工作表模板"
  9.     Range("a1").Select
  10. End Sub

  11. Sub 工作表模板()
  12.     Dim i As Long, year As Long, month As Long
  13.     Worksheets(1).Copy after:=Worksheets(Worksheets.Count)      '复制一张新表,新表的位置在最后
  14.     ActiveSheet.Range("b3:e4").ClearContents                    '去除上个月的数据
  15.     year = Left(Worksheets(Worksheets.Count - 1).Name, InStr(Worksheets(Worksheets.Count - 1).Name, "年") - 1)  '取前一个表的表名称中的年份和月份
  16.     month = Mid(Worksheets(Worksheets.Count - 1).Name, InStr(Worksheets(Worksheets.Count - 1).Name, "年") + 1, Len(Worksheets(Worksheets.Count - 1).Name) - InStr(Worksheets(Worksheets.Count - 1).Name, "年") - 1)
  17.     If month = 12 Then                  '如果前一张表是12月,那么新表的年份要加1,月份为1月。否则新表的年份保持不变,月份加1
  18.         year = year + 1
  19.         month = 1
  20.     Else
  21.         month = month + 1
  22.     End If
  23.    ActiveSheet.Name = year & "年" & month & "月"
  24. End Sub
复制代码
回复 支持 反对

使用道具 举报

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

本版积分规则

关闭

站长推荐上一条 /2 下一条

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