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

bynbyn

学员E13 bynbyn作业 我的第11课作业题.rar (17.56 KB, 下载次数: 4)

2012-3-30 16:50 上传

点击文件名下载附件

Private Sub 按月小计_Click()
    Dim rg As Range
    Dim x As Long
    Dim k As Long
    k = 2
    For x = 2 To Range("A65536").End(xlUp).Row '建立循环
      If Month(Cells(x, 1)) <> Month(Cells(x + 1, 1)) Then '判断单元格值
         Rows(x + 1).Insert Shift:=xlDown
         Cells(x + 1, 1) = "小计"
         Cells(x + 1, 3).Formula = "=sum(c" & k & ":c" & x & ")"
         Cells(x + 1, 4).Formula = "=sum(d" & k & ":d" & x & ")"
         k = x + 2
         x = x + 1
      End If
   Next x
   Cells(x + 2, 1) = "小计"
   Cells(x + 2, 3).Formula = "=sum(c" & k + 1 & ":c" & x & ")"
   Cells(x + 2, 4).Formula = "=sum(d" & k + 1 & ":d" & x & ")"
End Sub
Private Sub 当天出库为空_Click()
   
    Dim r As Range
    Range("E1") = "出库标记"
    Set r = Range("C2:C19").SpecialCells(xlCellTypeBlanks)
    r.Offset(0, 2) = 1

End Sub

Private Sub 恢复表格_Click()
   Dim rg As Range
   Set rg = Range("B2:B20").SpecialCells(xlCellTypeBlanks)
   rg.EntireRow.Delete
   Range("e1:e20").Delete
End Sub

byhdch

A09:byhdch

Sub 按月小计()
    Dim x As Integer
    For x = Range("a65536").End(xlUp).Row To 3 Step -1
        If Month(Cells(x, 1)) <> Month(Cells(x - 1, 1)) Then
            Rows(x).Insert shift:=xlDown
        End If
    Next x
    For x = 2 To Range("a65536").End(xlUp).Row + 1
        If Len(Cells(x, 1)) <> 0 Then
            m = m + Cells(x, 3)
            n = n + Cells(x, 4)
        Else
            Cells(x, 1) = "小计"
            Cells(x, 3) = m
            Cells(x, 4) = n
            m = 0
            n = 0
        End If
    Next x
End Sub

Sub e列填入1()
    Dim rg As Range
    j = Range("a65536").End(xlUp).Row
    For Each rg In Range(Cells(2, 3), Cells(j, 3))
        If rg = "" Then rg.Offset(0, 2) = 1
    Next rg
End Sub

Sub 恢复数据()
    Dim rg As Range
    j = Range("a65536").End(xlUp).Row
    For Each rg In Range(Cells(2, 2), Cells(j, 2))
        If rg = "" Then rg.EntireRow.Delete
    Next rg
    Range(Cells(2, 5), Cells(j, 5)).ClearContents
End Sub

第11课作业题-A09byhdch.rar (14.97 KB, 下载次数: 2)

2012-3-30 22:01 上传

点击文件名下载附件

chenzhi_juan

Private Sub CommandButton1_Click()
Dim x As Integer, m1 As Integer, m2 As Integer
  Dim k As Integer
  m1 = 2
  For x = 2 To 1000
     If Cells(x, 1) = "" Then Exit Sub
     If Month(Cells(x, 1)) <> 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 & ")"
      Range(Cells(x + 1, "c"), Cells(x + 1, "d")).FillRight
      x = x + 1
      m1 = m2 + 2
      End If
     Next x
End Sub

Private Sub CommandButton2_Click()
Intersect(Range("e1:e20"), Range("d:d").SpecialCells(xlCellTypeBlanks).EntireRow) = 1
End Sub
Private Sub CommandButton3_Click()
Range("e2:e20").ClearContents
Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

wxfx1228

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()
Dim i As Integer
For i = 2 To Range("d65536").End(xlUp).Row
If Range("d" & i) = "" Then
Range("e" & i) = 1
End If
Next i
End Sub
Private Sub CommandButton3_Click()
Range("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

w2001pf

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

2012-3-31 08:13 上传

点击文件名下载附件
Private Sub CommandButton1_Click()
Dim x, k, t
t = Range("A65536").End(xlUp).Row + 1
k = 2
For x = k To t
    If VBA.Month(Cells(x, 1)) <> VBA.Month(Cells(x + 1, 1)) Then
        Rows(x + 1).Insert
        Cells(x + 1, 1).Value = "小计"
        Cells(x + 1, 3) = Application.Sum(Range(Cells(k, 3), Cells(x, 3)))
        Cells(x + 1, 4) = Application.Sum(Range(Cells(k, 4), Cells(x, 4)))
        k = x + 2
        x = k
        t = Range("A65536").End(xlUp).Row
    End If
Next x
  Cells(t + 1, 1).Value = "小计"
  Cells(t + 1, 3) = Application.Sum(Range(Cells(k, 3), Cells(t, 3)))
  Cells(t + 1, 4) = Application.Sum(Range(Cells(k, 4), Cells(t, 4)))
End Sub

Private Sub CommandButton2_Click()
Application.Intersect(Range("c2:c" & Range("A65536").End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow, Columns(5)).Value = 1
End Sub
Private Sub CommandButton3_Click()
Range("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Range("e2:e" & Range("e65536").End(xlUp).Row) = ""
End Sub

yl_li

Private Sub CommandButton1_Click()
Dim i, j, k
    With Sheets("sheet2")
        For i = .Range("a" & Rows.Count).End(xlUp).Row To 3 Step -1
            If VBA.Month(.Cells(i, 1)) <> VBA.Month(.Cells(i - 1, 1)) Then
                .Cells(i, 1).EntireRow.Insert
                .Cells(i, 1) = "小计"
            End If
        Next i
        .Cells(.Range("a" & Rows.Count).End(xlUp).Row + 1, 1) = "小计"
        j = 2
        Do  '循环开始的时候i值为2
            i = i + 1
            If .Cells(i, 1) = "小计" Then
                k = i - 1
                .Cells(i, 3) = "=sum(c" & j & ":c" & k & ")"
                .Cells(i, 4) = "=sum(d" & j & ":d" & k & ")"
                j = i + 1
            End If
        Loop Until i = .Range("a" & Rows.Count).End(xlUp).Row
    End With
End Sub
Private Sub CommandButton2_Click()
Dim i As Integer
    With Sheets("sheet2")
        .Range("e1") = "发出标记"
        i = .Range("c" & Rows.Count).End(xlUp).Row
        .Range("c2:c" & i).SpecialCells(xlCellTypeBlanks).Offset(0, 2) = 1
    End With
End Sub
Private Sub CommandButton3_Click()
    With Sheets("sheet2")
        .Columns(5).Delete
        .Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
End Sub
第11课作业题-yl_li.rar (21.61 KB, 下载次数: 3)

2012-3-31 10:23 上传

点击文件名下载附件

tytytty

D13:tytytty交作业，辛苦老师

1 (1)

1. 
   
2. Private Sub CommandButton1_Click()
   
3.     Dim i%, rg As Range, xx As Long, x%, x1%
   
4.     For i = 2 To Range("A65536").End(xlUp).Row
   
5.         If Month(Cells(i, 1)) <> Month(Cells(i + 1, 1)) Then
   
6.             If rg Is Nothing Then
   
7.                 Set rg = Rows(i + 1)
   
8.             Else
   
9.                 Set rg = Union(rg, Rows(i + 1))
   
10.             End If
    
11.         End If
    
12.     Next i
    
13.     rg.Select
    
14.     Selection.Insert Shift:=xlDown
    
15.     xx = Range("A65536").End(xlUp).Row + 1
    
16.     Range("A2:A" & xx).Select
    
17.     Selection.SpecialCells(xlCellTypeBlanks) = "小计"
    
18.     For i = 2 To Range("a65536").End(xlUp).Row
    
19.         If Cells(i, 1) <> "小计" Then
    
20.             x = x + Cells(i, 3)
    
21.             x1 = x1 + Cells(i, 4)
    
22.         Else
    
23.             Cells(i, 3) = x
    
24.             Cells(i, 4) = x1
    
25.             x = 0
    
26.             x1 = 0
    
27.         End If
    
28.     Next
    
29. End Sub
    

复制代码

1 (2)

1. Sub test()
   
2.     Dim i%, x%, x1%
   
3.     For i = Range("a65536").End(xlUp).Row + 1 To 3 Step -1
   
4.         If Month(Range("a" & i)) <> Month(Range("a" & i - 1)) Then
   
5.             Rows(i).Insert
   
6.             Cells(i, 1) = "小计"
   
7.         End If
   
8.     Next
   
9.     For i = 2 To Range("a65536").End(xlUp).Row
   
10.         If Cells(i, 1) <> "小计" Then
    
11.             x = x + Cells(i, 3)
    
12.             x1 = x1 + Cells(i, 4)
    
13.         Else
    
14.             Cells(i, 3) = x
    
15.             Cells(i, 4) = x1
    
16.             x = 0
    
17.             x1 = 0
    
18.         End If
    
19.     Next
    
20. End Sub
    

复制代码

2

1. 
   
2. Private Sub CommandButton2_Click()
   
3.     Dim m As Long
   
4.     m = Range("C65536").End(xlUp).Row
   
5.     Range("C2:C" & m).SpecialCells(xlCellTypeBlanks).Offset(, 2).Value = 1
   
6. End Sub
   

复制代码

3

1. Private Sub CommandButton3_Click()
   
2.     Dim x%
   
3.     For x = 2 To Range("E65536").End(xlUp).Row
   
4.         Cells(x, 5).ClearContents
   
5.     Next
   
6.     Range("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
   
7. End Sub

复制代码

11.xls (35.5 KB, 下载次数: 1)

2012-3-31 10:28 上传

点击文件名下载附件

bl5062

1. 
   
2. Option Explicit
   
3. Dim maxrow As Long
   
4. 
   
5. Private Sub CommandButton1_Click()
   
6.     Dim i As Long
   
7.     Dim uprow As Long
   
8.     maxrow = Cells(Rows.Count, 1).End(3).Row
   
9.     uprow = 2
   
10.     For i = 3 To maxrow + 10
    
11.         If Left(Cells(i, 1), 7) <> Left(Cells(i - 1, 1), 7) Then
    
12.             If Cells(i, 1) = "小计" Then Exit Sub
    
13.             Rows(i).Insert (xlShiftDown)
    
14.             Cells(i, 1) = "小计"
    
15.             Cells(i, 3) = "=sum(c" & uprow & ":c" & i - 1 & ")"
    
16.             Cells(i, 4) = "=sum(d" & uprow & ":d" & i - 1 & ")"
    
17.             i = i + 1
    
18.             uprow = i
    
19.         End If
    
20.     Next i
    
21. End Sub
    
22. 
    
23. Private Sub CommandButton2_Click()
    
24.     maxrow = Cells(Rows.Count, 1).End(3).Row
    
25.     Range("C1:C" & maxrow).Select
    
26.     Intersect(Selection.SpecialCells(xlCellTypeBlanks).EntireRow, Columns(5)) = 1
    
27. End Sub
    
28. Private Sub CommandButton3_Click()
    
29.     maxrow = Cells(Rows.Count, 1).End(3).Row
    
30.     Range("E2:E" & maxrow).ClearContents
    
31.     Range("B1:B" & maxrow + 1).Select
    
32.     Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
33. End Sub
    

复制代码

16组bl5062

wangchangjun

1. Private Sub CommandButton1_Click()
   
2. On Error GoTo 100
   
3. Dim x, y, jk
   
4. jk = 2
   
5. y = [a65536].End(xlUp).Row
   
6. For x = y + 1 To 3 Step -1
   
7. If Month(Cells(x, 1)) <> Month(Cells(x - 1, 1)) Then
   
8. Rows(x).Insert
   
9. Cells(x, 1) = "小计"
   
10. End If
    
11. Next
    
12. y = [a65536].End(xlUp).Row
    
13. For x = 2 To y
    
14. If Cells(x, 1) = "小计" Then
    
15. If jk = 2 Then
    
16. Cells(x, 3).Value = Application.WorksheetFunction.Sum(Range(Range("c" & jk), Range("c" & x - 1)))
    
17. Cells(x, 4).Value = Application.WorksheetFunction.Sum(Range(Range("d" & jk), Range("d" & x - 1)))
    
18. jk = Cells(x, 1).Row
    
19. Else
    
20. Cells(x, 3).Value = Application.WorksheetFunction.Sum(Range(Range("c" & jk + 1), Range("c" & x - 1)))
    
21. Cells(x, 4).Value = Application.WorksheetFunction.Sum(Range(Range("d" & jk + 1), Range("d" & x - 1)))
    
22. jk = Cells(x, 1).Row
    
23. End If
    
24. End If
    
25. Next
    
26. 100: Exit Sub
    
27. End Sub
    
28. 
    
29. Private Sub CommandButton2_Click()
    
30. Dim x As Integer
    
31. x = [a65536].End(xlUp).Row
    
32. Range(Range("c2"), Range("c" & x)).SpecialCells(xlCellTypeBlanks).Offset(, 2) = 1
    
33. End Sub
    
34. Private Sub CommandButton3_Click()
    
35. On Error Resume Next
    
36. Dim x As Integer
    
37. x = [a65536].End(xlUp).Row
    
38. Range(Range("b2"), Range("b" & x)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
39. Range(Range("e2"), Range("e" & x)).ClearContents
    
40. End Sub

复制代码

我不知道呀

第一个按钮：
Sub 按月小计()
    Dim y As Integer
    Dim x As Integer
    Dim k As Integer
    x = 16
    Cells([A65536].End(xlUp).Row + 1, 1) = "小计"
    For y = 15 To 2 Step -1
        If Mid(Cells(x - k, 1), 6, 1) <> Mid(Cells(y, 1), 6, 1) Then
            Rows(y + 1).Insert
            Cells(y + 1, 1) = "小计"
        End If
        k = k + 1
    Next y
    Call bb
End Sub
Sub bb()
    Dim m As Integer
    Dim i As Integer
    Dim o As Integer
    Dim p As Integer
    i = Range("a65536").End(xlUp).Row
    p = 2
    For m = p To i
        o = o + 1
        If Cells(m, 1) = "小计" Then
            Cells(m, 3) = WorksheetFunction.Sum(Range(Cells(m - o + 1, 3), Cells(m - 1, 3)))
            Cells(m, 4) = WorksheetFunction.Sum(Range(Cells(m - o + 1, 4), Cells(m - 1, 4)))
            o = 0
        End If
    Next
End Sub

第二个按钮：
Sub 发出为空的行E列填入数字1()
    Application.Intersect(Range("d2:d20").SpecialCells(xlCellTypeBlanks).EntireRow, Columns(5)) = 1
End Sub

第三个按钮：
Sub dd()
    Range("b:b").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Columns(5).ClearContents
End Sub