统计VBA学习小组正式组的积分帖之作业上交贴（第14周）

gaoshuichang1

第11课作业题.zip (16.61 KB, 下载次数: 7)

2012-3-29 16:28 上传

点击文件名下载附件
Sub 按月小计()
Dim x As Integer, m1 As Integer, m2 As Integer
  m1 = 2
  For x = 2 To 100
    If Cells(x, 1) = "" Then Exit Sub
    If VBA.Month(Cells(x, 1)) <> VBA.Month(Cells(x + 1, 1)) Then
        m2 = x
        Rows(x + 1).Insert
        Cells(x + 1, "a") = " 小计"
        Cells(x + 1, "c") = "=sum(c" & m1 & ":c" & m2 & ")"
        Cells(x + 1, "c").Resize(1, 2).FillRight
        Cells(x + 1, "b") = ""
        Cells(x + 1, "e") = ""
        x = x + 1
        m1 = m2 + 2
    End If
  Next x
End Sub
*************************************************************************
Sub 发出为空的行e列填入数字()
   
Dim x As Range
Dim y As Range
Set x = Range("c2:c16").SpecialCells(xlCellTypeBlanks).EntireRow
Set y = Intersect(x, Columns(5))
y.Select
y = 1
End Sub
**************************************************************

Sub 恢复表格()
Range("B1:b50").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Range("e2:e50").ClearContents
End Sub

sliang28

校长，第一个是不是有点复杂了？要判断日期的

1. 
   
2. Private Sub CommandButton1_Click()
   
3. Dim rg As Range
   
4. Dim i As Integer
   
5. Dim a(100) As Integer
   
6. Dim b(1 To 100) As Integer
   
7. Dim i_past As Integer
   
8. Dim insertrow As String
   
9. Dim t As Integer
   
10. Dim s As Integer
    
11. i = 1
    
12. t = 1
    
13. s = 2
    
14. a(0) = 2
    
15. On Error Resume Next
    
16. For Each rg In [A2: A16]
    
17.     a(i) = Month(rg.Value)
    
18.     If a(i - 1) < a(i) Then
    
19.        b(i) = i + 1
    
20.     End If
    
21.     i = i + 1
    
22. Next
    
23. For i = 1 To 20
    
24. If b(i) <> 0 Then
    
25.    b(i) = b(i) + t
    
26.    Rows(b(i) - 1).Insert
    
27.    Range("a" & b(i) - 1) = "小计"
    
28.    Range("c" & b(i) - 1) = Application.WorksheetFunction.Sum(Range("c" & s & " :" & "c" & b(i) - 1))
    
29.    Range("d" & b(i) - 1) = Application.WorksheetFunction.Sum(Range("d" & s & " :" & "d" & b(i) - 1))
    
30.    s = b(i)
    
31.    t = t + 1
    
32. End If '
    
33. Next i
    
34. Range("a65536").End(xlUp).Offset(1, 0) = "小计"
    
35. Range("a65536").End(xlUp).Offset(0, 2) = Application.WorksheetFunction.Sum(Range("c" & s & " :" & "c" & Range("a65536").End(xlUp).Row - 1))
    
36. Range("a65536").End(xlUp).Offset(0, 3) = Application.WorksheetFunction.Sum(Range("D" & s & " :" & "D" & Range("a65536").End(xlUp).Row - 1))
    
37. End Sub
    
38. 
    
39. Private Sub 按月小计1()
    
40. Dim rg As Range
    
41. Dim i As Integer
    
42. Dim i_past As Integer
    
43. Dim insertrow As String
    
44. 
    
45. For Each rg In [A2:A16]
    
46.     i = Month(rg.Value)
    
47.     If i <> i_past Then
    
48.         If insertrow <> "" Then
    
49.             insertrow = insertrow & "," & rg.Row & ":" & rg.Row
    
50.         Else
    
51.             insertrow = insertrow & rg.Row & ":" & rg.Row
    
52.         End If
    
53.     End If
    
54. 
    
55. 
    
56. Next
    
57. 
    
58. Range("6:6,11:11,15:15").Insert
    
59. 
    
60. End Sub
    
61. 
    
62. Private Sub CommandButton2_Click()
    
63.    
    
64.    Range("C2:C16").SpecialCells(xlCellTypeBlanks).Offset(0, 2) = 1
    
65.       
    
66. End Sub
    
67. 
    
68. 
    
69. Private Sub CommandButton3_Click()
    
70.    
    
71.     Range("B2:B20").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
72.         
    
73.         Range("e2:e20").ClearContents
    
74. End Sub

复制代码

sliang28

校长：
对不起！
13楼的答案中第38行到59行是不要的，忘记删除了。

yu20078

Private Sub CommandButton1_Click() '按月小计
Dim c, i, x, s1, s2
c = [a65536].End(xlUp).Row + 12
x = 2
s1 = [c2]: s2 = [d2]
For i = 2 To c
    If Range("a" & i) <> "" And Month(Range("a" & i)) <> Month(Range("a" & i + 1)) Then
        Range("a" & i + 1).EntireRow.Insert
        Range("a" & i + 1) = "合计"
        Range("c" & i + 1) = s1
        Range("d" & i + 1) = s2
        x = i + 2
        i = i + 1
        s1 = Range("c" & i + 1)
        s2 = Range("d" & i + 1)
    Else
        s1 = s1 + Range("c" & i + 1)
        s2 = s2 + Range("d" & i + 1)
    End If
Next i
End Sub

Private Sub CommandButton2_Click() '根据以列空在E列填数字1
Dim b
b = [c65536].End(xlUp).Row
Intersect(Columns("e:e"), Range("c1:c" & b).SpecialCells(xlCellTypeBlanks).EntireRow) = 1
End Sub

Private Sub CommandButton3_Click() '恢复表格
Dim a
a = [b65536].End(xlUp).Row + 1
Range("e2:e" & a).ClearContents
Range("b1:b" & a).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

mfksypss

Option Explicit
Private Sub CommandButton1_Click()
    Dim n%, mo%, m1%
    m1 = 2
    For n = 2 To 100
        If Month(Range("A" & n)) <> Month(Range("A" & n + 1)) Then
            n = n + 1
            Rows(n).Insert
            Cells(n, 1) = "小计"
            Cells(n, 3) = Application.WorksheetFunction.Sum(Range("C" & m1 & ":C" & n - 1))
            Cells(n, 4) = Application.WorksheetFunction.Sum(Range("D" & m1 & ":d" & n - 1))
            n = n + 1
            m1 = n
        End If
    Next n
End Sub
Private Sub CommandButton2_Click()
    Application.Intersect(Range("D2:D" & Range("a63556").End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow, Range("E:E")) = 1
End Sub
Private Sub CommandButton3_Click()
    Range("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Range("E2:e16") = ""
End Sub

vbamaster

Private Sub CommandButton1_Click()

    Application.ScreenUpdating = False

    Dim FirstNumer, LastNumber As Integer
    Dim x As Long

    FirstNumer = 2

    For x = 2 To Rows.Count
        If Range("a" & x) = "" Then Exit Sub
        If VBA.Month(Range("a" & x)) <> VBA.Month(Range("a" & x + 1)) Then
            LastNumber = x
            Range("a" & x + 1).EntireRow.Insert
            Range("a" & x + 1).Range("a1") = "小计："
            Range("a" & x + 1).Range("c1") = WorksheetFunction.Sum(Range("c" & FirstNumer & ":" & "c" & LastNumber))
            Range("a" & x + 1).Range("d1") = WorksheetFunction.Sum(Range("d" & FirstNumer & ":" & "d" & LastNumber))
            x = x + 1
            FirstNumer = x + 1
        End If
    Next x

    Application.ScreenUpdating = True

End Sub

Private Sub CommandButton2_Click()

    Application.ScreenUpdating = False

    Dim rg As Range
    For Each rg In Range("c1:c" & Range("c" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeBlanks)
        rg.Range("c1") = 1
    Next rg

    Application.ScreenUpdating = True

End Sub

Private Sub CommandButton3_Click()

    On Error Resume Next
    Range("b1:b" & Range("c" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Range("e2:e" & Rows.Count).ClearContents

End Sub

第11课作业题.rar (13.89 KB, 下载次数: 3)

2012-3-29 23:19 上传

点击文件名下载附件
兰版辛苦了！
D05:vbamaster

心灯芯

Private Sub CommandButton1_Click()
    Dim a As Integer, c As Integer, i As Integer
    a = [a65536].End(3).Row + 1
    c = 2: i = 2
    Do Until i >= a
        If Month(Cells(i, 1)) <> Month(Cells(i + 1, 1)) Then
            Cells(i + 1, 1).EntireRow.Insert
            a = a + 1: i = i + 1
            Cells(i, 1) = "小计"
            Cells(i, 3) = Application.Sum(Range("C" & c, "C" & i - 1))
            Cells(i, 4) = Application.Sum(Range("D" & c, "D" & i - 1))
            c = i + 1
        End If
        i = i + 1
    Loop
End Sub
Private Sub CommandButton2_Click()
Range("c1:c" & [a65536].End(3).Row).SpecialCells(xlCellTypeBlanks).Offset(0, 2) = 1
End Sub
第11课作业题.rar (26.96 KB, 下载次数: 3)

2012-3-30 00:08 上传

点击文件名下载附件
Private Sub CommandButton3_Click()
Range("B1:B" & [a65536].End(3).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

gaoshuichang1

第11课作业题.zip (16.56 KB, 下载次数: 3)

2012-3-30 11:23 上传

点击文件名下载附件
Sub 按月小计()
Dim x As Integer, m1 As Integer, m2 As Integer
  m1 = 2
  For x = 2 To 50
    If Cells(x, 1) = "" Then Exit Sub
    If VBA.Month(Cells(x, 1)) <> VBA.Month(Cells(x + 1, 1)) Then
        m2 = x
        Rows(x + 1).Insert
        Cells(x + 1, "a") = " 小计"
        Cells(x + 1, "c") = "=sum(c" & m1 & ":c" & m2 & ")"
        Cells(x + 1, "c").Resize(1, 2).FillRight
        Cells(x + 1, "e") = ""
        x = x + 1
        m1 = m2 + 2
    End If
  Next x
End Sub
-------------------------------------------------------------------------------------------------------------------------------------
Sub 发出为空的行e列填入数字()
Dim x As Range
Dim y As Range
Set x = Range("c2:c16").SpecialCells(xlCellTypeBlanks).EntireRow
Set y = Intersect(x, Columns(5))
y = 1
End Sub
------------------------------------------------------------------------------------------------------------------------------------
Sub 恢复表格()
Range("B1:b50").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Range("e2:e50").ClearContents
End Sub

兰江自由鱼

作业代码如下，请批改。谢谢！
Private Sub CommandButton1_Click()   '分月小计
  Dim i As Integer, j As Integer, k As Integer, m As Integer
  m = Range("a65536").End(xlUp).Row
  i = 2
  Do
      j = i
      k = VBA.Month(Range("a" & i))
      Do
         i = i + 1
       Loop Until VBA.Month(Range("a" & i)) <> k
       Rows(i).Insert
       m = m + 1
       Range("a" & i) = "  小计 "
       Range("C" & i).Formula = "=sum(C" & j & ":C" & i - 1 & ")"
       Range("D" & i).Formula = "=sum(D" & j & ":D" & i - 1 & ")"
     i = i + 1
   Loop Until i > m
End Sub

Private Sub CommandButton2_Click()  '筛选
  Range("D2:D" & Range("a65536").End(xlUp).Row).SpecialCells(xlCellTypeBlanks).Offset(0, 1) = 1
End Sub

Private Sub CommandButton3_Click()  '恢复
   Range("B1:B20").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
   Range("E2:E20") = ""
End Sub


兰江自由鱼_第11课作业题.rar (24.26 KB, 下载次数: 8)

2012-3-30 14:20 上传

点击文件名下载附件

想飞的鸟

Private Sub CommandButton1_Click()
      Dim x, heji1, heji2
      heji1 = 0
      heji2 = 0

  For x = 2 To 30
    If Cells(x, 1) <> "" And Month(Cells(x, 1)) = Month(Cells(x + 1, 1)) Then
              heji1 = heji1 + Range("c" & x)
              heji2 = heji2 + Range("d" & x)
   ElseIf Cells(x, 1) <> "" And Month(Cells(x, 1)) <> Month(Cells(x + 1, 1)) Then
              heji1 = heji1 + Range("c" & x)
              heji2 = heji2 + Range("d" & x)
              Rows(x + 1).Insert
              Range("a" & x + 1) = "小计"
              Range("c" & x + 1) = heji1
              Range("d" & x + 1) = heji2
              x = x + 1
              heji1 = 0
              heji2 = 0
              End If
   Next
End Sub

Private Sub CommandButton2_Click()

    Range("E2").FormulaR1C1 = "=IF(RC[-1]="""",1,"""")"
    Range("E2").Select
    Selection.AutoFill Destination:=Range("e2:e19")
        '老师，我不知道怎样自动判断是最后一行为空，所以做了个死的，虽然能完成作业，但不完善，请帮一下

End Sub
Private Sub CommandButton3_Click()

Range("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Range("e2:e65536").ClearContents
End Sub