VBA实战开发第五期-第三课作业贴

唐伯狼

VBA实战开发第五期-第三课作业贴

sweet17tian

数组 留级的练习

1. Sub 留级情况()
   
2.     Dim arr()
   
3.     Dim i As Long, k As Long
   
4.     arr = Range("a1").CurrentRegion
   
5.     ReDim brr(UBound(arr), 1 To 3)
   
6.     brr(1, 1) = arr(1, 1)
   
7.     brr(1, 2) = arr(1, 2)
   
8.     brr(1, 3) = "结果"
   
9.     k = 1
   
10.     For i = 2 To UBound(arr)
    
11.         If arr(i, 2) < 60 Then
    
12.             k = k + 1
    
13.             brr(k, 1) = arr(i, 1)
    
14.             brr(k, 2) = arr(i, 2)
    
15.             brr(k, 3) = "留级"
    
16.         End If
    
17.     Next
    
18. Range("d5").Resize(UBound(brr), UBound(brr, 2)) = brr
    
19. 
    
20. 
    
21. End Sub
    

复制代码

城市划分等级的练习

1. Sub 城市()
   
2.    
   
3.     Dim arr(), brr(), crr()
   
4.     Dim sht1 As Worksheet, sht2 As Worksheet
   
5.     Dim i As Long, j As Long, k As Long, t
   
6.     Set sht1 = Worksheets("sheet1")
   
7.     Set sht2 = Worksheets("sheet2")
   
8.     t = Timer
   
9.     arr = sht2.Range("a1").CurrentRegion
   
10.     brr = sht1.Range("a1").CurrentRegion
    
11.     ReDim crr(1 To UBound(brr), 1 To 1)
    
12.         For k = 1 To UBound(brr)
    
13.         For i = 2 To UBound(arr)
    
14.             For j = 1 To UBound(arr, 2)
    
15.                 If arr(i, j) = brr(k, 2) Then
    
16.                     crr(k, 1) = arr(1, j)
    
17.                     
    
18.                 End If
    
19.             Next
    
20.         Next
    
21.     Next
    
22.     sht1.Range("d1").Resize(UBound(crr), 1) = crr
    
23.     MsgBox Timer - t
    
24. End Sub

复制代码

sweet17tian

数组 户口练习

1. Sub 户主()
   
2.     Dim arr(), brr(), crr()
   
3.     Dim sht1 As Worksheet, sht2 As Worksheet
   
4.     Dim i As Long, j As Long, k As Long, 行 As Long, 填 As Long, l As Long
   
5.     Set sht1 = Worksheets("sheet1")
   
6.     Set sht2 = Worksheets("sheet2")
   
7.     arr = sht1.Range("b1").CurrentRegion
   
8.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
9.     k = 1
   
10.     For i = 2 To UBound(arr)
    
11.         If arr(i, 2) = sht2.Range("c2") Then
    
12.             行 = i
    
13.         End If
    
14.         If 行 <> 0 Then Exit For
    
15.     Next
    
16.    
    
17.     For i = 行 To UBound(arr)
    
18.         If arr(i, 2) = arr(i + 1, 2) Then
    
19.             sht2.Range("i4") = arr(i, 5)
    
20.             k = k + 1
    
21.         Else
    
22.             brr = Range(sht1.Cells(i - k + 1, 3), sht1.Cells(i, 7))
    
23.             Exit For
    
24.         End If
    
25.     Next
    
26.     填 = 14
    
27.     crr = Array("本人", "妻", "长子", "长女", "次子", "次女", "三子", "三女", "儿媳", "父亲", "母亲", "兄弟", "姐妹")
    
28.     For l = 0 To UBound(crr)
    
29.         For i = 1 To UBound(brr)
    
30.    
    
31.             If crr(l) = brr(i, 2) Then
    
32.                 填 = 填 + 1
    
33.                 sht2.Range("a" & 填) = brr(i, 1)
    
34.                 sht2.Range("c" & 填) = brr(i, 2)
    
35.                 sht2.Range("g" & 填) = brr(i, 3)
    
36.             End If
    
37.         
    
38.         Next
    
39.     Next
    
40. 
    
41. End Sub
    

复制代码

bolcom

1. Sub 城市数据()
   
2. Dim arr, brr, drr, i&, j&, p&
   
3. t = Timer
   
4. arr = Sheet1.Range("a1:c" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
   
5. brr = WorksheetFunction.Transpose(Sheet2.Range("a1").CurrentRegion)
   
6. ReDim drr(1 To UBound(arr))
   
7.     For i = 1 To UBound(arr)
   
8.         For p = 1 To UBound(brr)
   
9.             For j = 1 To UBound(brr, 2)
   
10.                 If brr(p, j) = "" Then Exit For
    
11.                     If arr(i, 2) = brr(p, j) Then
    
12.                     drr(i) = brr(p, 1)
    
13.                     GoTo line1
    
14.                 End If
    
15.             Next
    
16.         Next
    
17. line1:
    
18.     Next
    
19.     Sheet1.Range("d1").Resize(UBound(drr)) = WorksheetFunction.Transpose(drr)
    
20.     Sheet1.[e1] = Timer - t
    
21. End Sub
    
22. 
    

复制代码

bolcom

1. Sub 户口信息查询()
   
2. Dim arr, brr, crr(), counts%, i%, j%, rng As Range, n%
   
3. Sheet2.Range("a15:i21").ClearContents
   
4. counts = WorksheetFunction.CountIf(Sheet1.Range("b:b"), Sheet2.[c2].Value)
   
5. Set rng = Sheet1.Range("b:b").Find(Sheet2.[c2].Value, , , , xlByColumns, xlNext)
   
6. arr = rng.Resize(counts, 4)
   
7. brr = [{"本人","妻","长子","长女","次子","次女","三子","三女","儿媳","孙子"}]
   
8. ReDim crr(1 To counts, 1 To 9)
   
9.     For i = 1 To UBound(brr)
   
10.         For j = 1 To UBound(arr)
    
11.            If arr(j, 3) = brr(i) Then
    
12.                 n = n + 1
    
13.                 crr(n, 1) = arr(j, 1)
    
14.                 crr(n, 3) = arr(j, 3)
    
15.                 crr(n, 7) = arr(j, 4)
    
16.                 Exit For
    
17.            End If
    
18.         Next j
    
19.         If n = counts Then Exit For
    
20.     Next i
    
21.     Sheet2.Range("a15").Resize(counts, 9) = crr
    
22. End Sub
    

复制代码