4月17/18日 7天Excel脱白 300集Office 2010微视频教程
5月7日 Excel VBA开发实战 高效办公必会的Office实战技巧
4月11/12日 Excel函数实战技巧精粹 网易云课堂-Excel数据透视表应用大全
Excel数据处理与分析实战技巧第1季
查看: 498|回复: 31

零基础12期-第十三课作业

[复制链接]
发表于 2017-12-28 15:01:01 | 显示全部楼层 |阅读模式
本帖最后由 开心妙妙 于 2018-1-16 14:51 编辑

交作业之前先看群文件作业提交说明
回复

使用道具 举报

发表于 2017-12-29 10:22:14 | 显示全部楼层
本帖最后由 小白兔在大草原 于 2017-12-29 11:35 编辑
  1. Sub 分表()
  2.     Dim sht As Worksheet, i As Long, area As Range, st As Worksheet
  3.     Set area = Range("a1").CurrentRegion
  4.     Set sht = Sheets.Add
  5.     sht.Name = "人员"
  6.     Worksheets("销售表").Range("d:d").Copy Range("a1")
  7.     ActiveSheet.Range("a:a").RemoveDuplicates Columns:=1, Header:=xlYes
  8.     For i = 2 To Range("a1").CurrentRegion.Rows.Count
  9.         With Worksheets("销售表")
  10.             .Range("a1").CurrentRegion.AutoFilter Field:=4, Criteria1:=Worksheets("人员").Cells(i, 1)
  11.             Sheets.Add After:=Sheets(Sheets.Count)
  12.             ActiveSheet.Name = Sheets("人员").Cells(i, 1)
  13.             .Range("a1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy [a1]
  14.             .Range("a1").AutoFilter
  15.         End With
  16.     Next
  17.     For Each st In Worksheets
  18.         If st.Name <> "销售表" And st.Name <> "人员" Then
  19.             st.Copy
  20.             ActiveWorkbook.SaveAs ThisWorkbook.Path & "\人员" & st.Name & ".xlsx"
  21.             ActiveWorkbook.Close True
  22.         End If
  23.     Next
  24.     Application.DisplayAlerts = False
  25.     For Each st In Worksheets
  26.         If st.Name <> "销售表" Then st.Delete
  27.     Next
  28.     Application.DisplayAlerts = True
  29. End Sub
  30. Function myvlookup(lookupvalue, area As Range, col As Long)
  31.     Dim i As Long, rng As Range
  32.     Set rng = area.Find(lookupvalue)
  33.     myvlookup = Cells(rng.Row, col)
  34. End Function
  35. Sub 次数()
  36.     Dim findstr As String, str As String, i As Long, j As Long
  37.     findstr = "咳嗽"
  38.     str = "某老病人一直咳嗽不止,有天他去看医生。医生检查后问他:您20岁的时候有咳嗽的毛病吗?病人回答,不咳嗽。医生又问,那么你30岁时咳嗽过吗?病人回答没咳嗽过。医生再问,你40岁的时候咳嗽吗?病人回答不咳嗽。医生忍着性子问,50岁时候呢? _咳嗽吗?病人说,不咳嗽,不咳嗽。医生生气的说,那你现在还不咳嗽,还想什么时候咳嗽呢?"
  39.     j = InStr(1, str, findstr)
  40.     If j > 0 Then i = i + 1
  41.     Do Until j = 0
  42.         j = InStr(j + 1, str, findstr)
  43.         If j <> 0 Then i = i + 1
  44.     Loop
  45.     MsgBox i
  46. End Sub
复制代码

点评

不错,正确  发表于 2018-1-16 14:41
回复 支持 反对

使用道具 举报

发表于 2017-12-29 11:16:10 | 显示全部楼层

20行代码人员后面加一个\,保存不上去,在这里说明一下。
回复 支持 反对

使用道具 举报

发表于 2017-12-29 13:07:36 | 显示全部楼层
本帖最后由 huwenjun727 于 2017-12-29 15:54 编辑

  1. Sub homework1()
  2. Dim wb As Workbook, p As String, name As String, area As Range, i As Long
  3. Application.ScreenUpdating = False
  4. Application.DisplayAlerts = False
  5. Set area = [a1].CurrentRegion
  6.     Range("d1").Select
  7.     Range(Selection, Selection.End(xlDown)).Select
  8.     Selection.Copy
  9.     Sheets.Add After:=Sheets(Sheets.Count)
  10.     ActiveSheet.Paste
  11.     Application.CutCopyMode = False
  12.     [a1].EntireColumn.AdvancedFilter Action:=xlFilterInPlace, Unique _
  13.         :=True
  14.     [a1].CurrentRegion.Select
  15.     Selection.Copy
  16.     ActiveSheet.name = "删选"
  17.     Sheets.Add After:=Sheets(Sheets.Count)
  18.     ActiveSheet.Paste
  19.     ActiveSheet.name = "名单"
  20. For i = 2 To [a1].CurrentRegion.Rows.Count
  21.     Worksheets("名单").Activate
  22.     name = Cells(i, 1)
  23.     Worksheets("销售表").Activate
  24.     [a1].EntireRow.Select
  25.     Selection.AutoFilter
  26.     [a1].CurrentRegion.AutoFilter Field:=4, Criteria1:=name
  27.     [a1].Select
  28.     Range(Selection, Selection.End(xlDown)).Select
  29.     Range(Selection, Selection.End(xlToRight)).Select
  30.     Selection.Copy
  31.     Sheets.Add After:=Sheets(Sheets.Count)
  32.     ActiveSheet.Paste
  33.     Range(Selection, Selection.End(xlDown)).Select
  34.     Range(Selection, Selection.End(xlToRight)).Select
  35.     ActiveSheet.name = name
  36.     Selection.Copy
  37.    
  38.     Set wb = Workbooks.Add()
  39.     ActiveSheet.Paste
  40.     ActiveWorkbook.SaveAs name & ".xlsx"
  41.     ActiveWorkbook.Close
  42.    
  43.     Worksheets(name).Activate
  44.     ActiveWindow.SelectedSheets.Delete
  45.    
  46.     Worksheets("销售表").Activate
  47.     [a1].EntireRow.Select
  48.     Selection.AutoFilter
  49. Next i
  50.     Worksheets("删选").Activate
  51.     ActiveWindow.SelectedSheets.Delete
  52.     Worksheets("名单").Activate
  53.     ActiveWindow.SelectedSheets.Delete
  54.    
  55.     Application.ScreenUpdating = True
  56.     Application.DisplayAlerts = True
  57. End Sub

  58. 'Homework2
  59. Sub functiondemo()
  60.     MsgBox mylookup("王心刚", [a1].CurrentRegion, 2)
  61. End Sub

  62. Function mylookup(lookupvalue, area As Range, col As Long)
  63. Dim i As Long
  64. i = area.find(lookupvalue).Row
  65. Set area = [a1].CurrentRegion
  66. mylookup = Cells(i, col)

  67. End Function

  68. Sub homework3()
  69. Dim text, i As Long, x As Long, number As Long
  70.     i = 1
  71.     text = "某老病人一直咳嗽不止,有天他去看医生。医生检查后问他:您20岁的时候有咳嗽的毛病吗?病人回答,不咳嗽。医生又问,那么你30岁时咳嗽过吗?病人回答没咳嗽过。医生再问,你40岁的时候咳嗽吗?病人回答不咳嗽。医生忍着性子问,50岁时候呢?咳嗽吗?病人说,不咳嗽,不咳嗽。医生生气的说,那你现在还不咳嗽,还想什么时候咳嗽呢?"
  72.    Do Until InStr(i, text, "咳嗽") = 0
  73.         x = InStr(i, text, "咳嗽")
  74.         i = x + 2
  75.         number = number + 1
  76.   Loop
  77.         MsgBox number & "次咳嗽"

  78. End Sub
复制代码

点评

结果正确,不错  发表于 2018-1-16 14:42
作业1,拆分的分档没存到老师指定[人员]子目录中,是存在默认的我的文档中  发表于 2018-1-16 14:41
回复 支持 反对

使用道具 举报

发表于 2017-12-29 14:48:26 | 显示全部楼层
' 十三期作业1
Sub work13one()
Dim sht As Worksheet, f As String, area As Range, rng As Range, i As Long, 移动表 As Worksheet
    Set sht = Worksheets("销售表")
        sht.Activate
    Set area = Range("a1").CurrentRegion
        Columns("D:D").Copy                       '复制列
        Worksheets.Add after:=Worksheets(1)
        Range("a1").PasteSpecial                     '新建工作表并且粘贴
    ActiveSheet.Range("$A$1:$A$204").RemoveDuplicates Columns:=1, Header:=xlYes   '删除同类项
     Set rng = Range("a1").CurrentRegion
     For i = 2 To rng.Rows.Count
            f = rng.Range("a" & i)
          Worksheets.Add after:=Worksheets(Sheets.Count)
          ActiveSheet.Name = f            '新工作簿命名
          area.AutoFilter Field:=4, Criteria1:=f        '自动筛选对应人并复制到对应工作表
        With Worksheets(f)
            area.SpecialCells(xlCellTypeVisible).Copy .[a1]
        End With
            area.AutoFilter
       Set 移动表 = Worksheets(f)        '复制表格另存为以sheet.name的新的工作簿
            移动表.Copy
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\人员\" & 移动表.Name & ".xlsx"
          ActiveWorkbook.Close False
      Next
     Application.DisplayAlerts = False   '关闭系统提示的对话框
       For Each sht In Worksheets         '循环并,删除其他表
         If sht.Name <> "销售表" Then sht.Delete
       Next
    Application.DisplayAlerts = True      '打开系统提示的对话框
End Sub


Sub 咳嗽()
Dim str As String, 查找词 As String, i As Long, 次数 As Long, 位置 As Long
  str = Cells(1, 1)
  i = 1
  查找词 = "咳嗽"
  位置 = InStr(i, str, 查找词)
  次数 = 0
  Do
     i = i + 1
    If 位置 <> InStr(i, str, 查找词) Then
        位置 = InStr(i, str, 查找词)
        次数 = 次数 + 1
    End If
  Loop Until 位置 = 0
   MsgBox "一共出现了" & 次数 & "个咳嗽。"
End Sub

作业2,忘记要求了,晚上回去了再补

点评

不错,正确  发表于 2018-1-16 14:43
回复 支持 反对

使用道具 举报

发表于 2017-12-29 15:43:46 | 显示全部楼层
我是民航骄子

  1. Option Explicit

  2. '按销售表销售人员分表,分别存储成人名的工作簿存到人员子目录下。

  3. Sub 分表()

  4.     Application.DisplayAlerts = False

  5. '''''''''''''''''''''''''''''去重复项
  6.     Worksheets.Add after:=Worksheets("销售表")
  7.     ActiveSheet.Name = "销售人员名单 - 去重复"
  8.    
  9.     Worksheets("销售表").Activate
  10.    
  11.     With Worksheets("销售人员名单 - 去重复")
  12.         Range(Columns(4), Columns(4)).Copy .Range("a1")
  13.     End With
  14.    
  15.     Worksheets("销售人员名单 - 去重复").Activate
  16.     '去重复项
  17.     ActiveSheet.Range(Columns(1), Columns(1)).RemoveDuplicates Columns:=1, Header:=xlYes

  18.         
  19. ''''''''''''''''''''''''''''按重复项分表
  20.    
  21.    
  22.    
  23.     Dim r As Range
  24.      
  25.     For Each r In Worksheets("销售人员名单 - 去重复").Range("a1").CurrentRegion
  26.         Worksheets("销售表").Activate
  27.         If r.Value <> "销售人员" Then
  28.             
  29.             '人员选择并复制
  30.             Worksheets("销售表").Range("a1").CurrentRegion.AutoFilter Field:=4, Criteria1:=r.Value
  31.             
  32.             Worksheets.Add
  33.             ActiveSheet.Name = r.Value
  34.             
  35.             
  36.             Worksheets("销售表").Range("a1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Worksheets(r.Value).Range("a1")
  37.             
  38.             
  39.             'worksheet单独成为工作簿
  40.             Worksheets(r.Value).Copy
  41.             
  42.             ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & r.Value & ".xlsx"
  43.             
  44.             ActiveWorkbook.Close True
  45.             
  46.             
  47.         End If
  48.         
  49.     Next
  50.    
  51.     '关掉筛选
  52.     Worksheets("销售表").Activate
  53.     Selection.AutoFilter
  54.    
  55.     '删除临时工作表
  56.     Dim sht As Worksheet
  57.    
  58.     For Each sht In Worksheets
  59.         If sht.Name <> "销售表" Then sht.Delete
  60.     Next
  61.    
  62.     Application.DisplayAlerts = True
  63.    
  64. End Sub

复制代码





  1. Option Explicit

  2. 'myvlookup 函数
  3. 'vlookup(找谁,在哪找,返回谁)
  4. Sub functiondemo()
  5.     MsgBox mylookup("王心刚", [a1].CurrentRegion, 2)
  6. End Sub

  7. Function mylookup(lookupvalue, area As Range, col As Long)
  8.    
  9.   Dim r As Range
  10.   
  11.     For Each r In area
  12.         If r.Value = lookupvalue Then
  13.             mylookup = r.Offset(0, col - 1)
  14.             Exit For
  15.         End If
  16.     Next
  17.    
  18. End Function


复制代码




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

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

  7. Sub instrrr()

  8.     Dim str1 As String, str2 As String
  9.    
  10.     str1 = "某老病人一直咳嗽不止,有天他去看医生。医生检查后问他:您20岁的时候有咳嗽的毛病吗?病人回答,不咳嗽。医生又问,那么你30岁时咳嗽过吗?病人回答没咳嗽过。医生再问,你40岁的时候咳嗽吗?病人回答不咳嗽。医生忍着性子问,50岁时候呢?咳嗽吗?病人说,不咳嗽,不咳嗽。医生生气的说,那你现在还不咳嗽,还想什么时候咳嗽呢?"
  11.    
  12.     str2 = "咳嗽"
  13.    
  14.     'num 表示出现的次数,position表示每次出现的位置
  15.     Dim num As Long, position As Long
  16.     position = 1
  17.    
  18.     Do While InStr(position, str1, str2) <> 0
  19.         num = num + 1
  20.         position = InStr(position, str1, str2) + 1
  21.     Loop
  22.    
  23.    
  24.     Debug.Print num

  25. End Sub
复制代码

点评

作业1,拆分的分档没存到老师指定[人员]子目录中,是存在ThisWorkbook目录中,整体不错,正确  发表于 2018-1-16 14:44
回复 支持 反对

使用道具 举报

发表于 2017-12-29 16:22:56 | 显示全部楼层
本帖最后由 chymmych 于 2017-12-29 23:15 编辑
  1. Option Explicit

  2. '作业一,按销售表销售人员分表,分别存储成人名的工作簿存到人员子目录下。
  3. Sub FenBiao()
  4.     Dim i As Long, val As String, j As Long, sht As Worksheet, wb As Workbook
  5.     Application.ScreenUpdating = False
  6.     Application.DisplayAlerts = False
  7.     With Sheets("销售表")
  8.         .Columns(4).Copy [l1]
  9.         .Columns(12).RemoveDuplicates Columns:=1, Header:=xlYes '去重复
  10.         j = [l1].CurrentRegion.Rows.Count
  11.         For i = 2 To j
  12.             val = .Cells(i, "l")
  13.             .[a1].CurrentRegion.AutoFilter Field:=j - 1, Criteria1:=val
  14.             Set sht = Worksheets.Add
  15.             sht.Name = val
  16.             .[a1].CurrentRegion.Copy Sheets(val).[a1]
  17.             ActiveSheet.Move
  18.             ActiveSheet.SaveAs "d:\人员" & val & ".xlsx"
  19.             ActiveWorkbook.Close False
  20.             .[a1].CurrentRegion.AutoFilter Field:=j - 1
  21.         Next
复制代码

点评

不错,正确  发表于 2018-1-16 14:44
回复 支持 反对

使用道具 举报

发表于 2017-12-30 18:49:55 | 显示全部楼层
  1. Sub 十二课1题()
  2.     Application.DisplayAlerts = False
  3.     Workbooks.Add
  4.     Worksheets.Add
  5.     ActiveSheet.Name = "零基础VBA"
  6.     ActiveSheet.Copy after:=Worksheets(Sheets.Count)
  7.     ActiveSheet.Name = "胡说老师"
  8.     ActiveWorkbook.SaveAs "D:" & "零基础VBA.xlsx"
  9.     Worksheets("零基础VBA").Delete
  10.     ActiveWorkbook.Close False
  11.     Application.DisplayAlerts = True
  12. End Sub
  13. '按销售表销售人员分表,分别存储成人名的工作簿存到人员子目录下。
  14. Sub 按销售人员分表()
  15.     Application.ScreenUpdating = False
  16.     Dim rng, area As Range, i As Long, ShtName As String
  17.     Set area = Sheet1.Range("A1").CurrentRegion
  18.     Range("D1", Range("D1").End(xlDown)).Copy [J1]
  19.     Range("J1", Range("J1").End(xlDown)).RemoveDuplicates Columns:=1
  20.     Set rng = Range("J1").CurrentRegion
  21.     area.AutoFilter
  22.     For i = 2 To rng.Rows.Count
  23.         ShtName = Sheet1.Range("J" & i)
  24.         Worksheets.Add after:=Worksheets(Sheets.Count)
  25.         ActiveSheet.Name = ShtName
  26.         area.AutoFilter field:=4, Criteria1:=ShtName
  27.         Sheet1.Range("A1").CurrentRegion.Copy Worksheets(ShtName).Range("A1")
  28.         Worksheets(ShtName).Copy
  29.         ActiveWorkbook.SaveAs ThisWorkbook.Path & "\人员" & ShtName & ".xlsx"
  30.         ActiveWorkbook.Close False
  31.     Next
  32.     Application.ScreenUpdating = True
  33. End Sub
  34. 'myvlookup 函数
  35. 'vlookup(找谁,在哪找,返回谁)
  36. Function mylookup(lookupvalue, area As Range, col As Long)
  37.     Dim i&, j&
  38.     For j = 1 To area.Columns.Count
  39.         For i = 1 To area.Rows.Count
  40.             If InStr(Cells(i, j), lookupvalue) > 0 Then
  41.                 mylookup = Cells(i, col)
  42.                 Exit For
  43.             End If
  44.         Next
  45.     Next
  46. End Function
  47. '编程解答一共出现了多少个咳嗽
  48. Sub 咳嗽()
  49.     Dim i&, SumV&, lenV&, c&, str As String
  50.     str = "某老病人一直咳嗽不止,有天他去看医生。医生检查后问他:您20岁的时候有咳嗽的毛病吗?" & _
  51.     "病人回答,不咳嗽。医生又问,那么你30岁时咳嗽过吗?病人回答没咳嗽过。" & _
  52.     "医生再问,你40岁的时候 咳嗽吗?病人回答不咳嗽。医生忍着性子问,50岁时候呢?咳嗽吗?" & _
  53.     "病人说,不咳嗽,不咳嗽。医生生气的说,那你现在还不咳嗽,还想什么时候咳嗽呢?"
  54.     lenV = Len(str)
  55.     Do
  56.         i = SumV + 1
  57.         SumV = InStr(i, str, "咳嗽")
  58.         If SumV > 0 Then
  59.             c = c + 1
  60.         Else
  61.             Exit Do
  62.         End If
  63.     Loop
  64.     Debug.Print "文本中共出现" & c & "个咳嗽"
  65. End Sub
复制代码

点评

不错,正确  发表于 2018-1-16 14:45
回复 支持 反对

使用道具 举报

发表于 2018-1-1 16:30:22 | 显示全部楼层
  1. Private Sub
  2. Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  3. ‘聚光灯
  4. Application.ScreenUpdating = False
  5. Dim i%, j%, k As Range, l As Range
  6. i = Target.Row
  7. j = Target.Column
  8. Set k = Range("a1").CurrentRegion

  9. With Cells.Interior
  10.         .Pattern = xlNone
  11.         .TintAndShade = 0
  12.         .PatternTintAndShade = 0
  13. End With
  14. Set l = Intersect(Target, k)
  15. If Not l Is Nothing And Target.Count = 1 Then

  16. With Intersect(k, Rows(Target.Row)).Interior
  17.         .Pattern = xlSolid
  18.         .PatternColorIndex = xlAutomatic
  19.         .Color = 65535
  20.         .TintAndShade = 0
  21.         .PatternTintAndShade = 0
  22.     End With
  23.   With Intersect(k, Columns(Target.Column)).Interior
  24.         .Pattern = xlSolid
  25.         .PatternColorIndex = xlAutomatic
  26.         .Color = 65535
  27.         .TintAndShade = 0
  28.         .PatternTintAndShade = 0
  29.     End With
  30.    With Target.Interior
  31.         .Pattern = xlNone
  32.         .TintAndShade = 0
  33.         .PatternTintAndShade = 0
  34. End With
  35. End If
  36. Application.ScreenUpdating = True
  37. End Sub
复制代码
回复 支持 反对

使用道具 举报

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

本版积分规则

关闭

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

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