[通知] 统计VBA学习小组正式组的积分帖之作业上交贴（第16周）

开心rabbit

A08-13课作业.rar (8.25 KB, 下载次数: 3)

2012-4-29 20:44 上传

点击文件名下载附件
Sub 第一题()
Dim arr, x As Integer, y As Integer
arr = Range("a1:d17")
For x = 1 To UBound(arr)
   For y = 1 To UBound(arr, 2)
     If arr(x, y) < 0 Then arr(x, y) = 0
   Next y
Next x
Range("g1:j17") = " "
Range("g1").Resize(UBound(arr), UBound(arr, 2)) = arr
End Sub
Sub 第二题()
Dim arr, k As Integer, x As Integer, y As Integer
Dim arr1(1 To 100, 1 To 1)
k = 1
arr = Range("a1:d17")
For x = 1 To UBound(arr)
   For y = 1 To UBound(arr, 2)
     If arr(x, y) < 0 Then
     arr1(k, 1) = arr(x, y)
     k = k + 1
     End If
    Next y
Next x
Range("m1:m100") = arr1
End Sub

gaoshuichang1

13课作业.rar (8.06 KB, 下载次数: 4)

2012-4-29 20:45 上传

点击文件名下载附件

1. Sub a()
   
2. Dim x As Integer, y As Integer
   
3. Dim arr
   
4. arr = Range("a1:d17")
   
5. For x = 1 To 17
   
6.     For y = 1 To 4
   
7.         If arr(x, y) < 0 Then
   
8.             arr(x, y) = 0
   
9.         End If
   
10.     Next y
    
11. Next x
    
12. Range("g1").Resize(17, 4) = arr
    
13. End Sub
    

复制代码

1. Sub b()
   
2. Dim arr, arr1(1 To 10000, 1 To 1)
   
3. Dim x As Integer, y As Integer, k As Integer, m As Integer
   
4. arr = Range("a1:d17")
   
5. m = Application.CountIf(Range("a1:d17"), "<0")
   
6. For x = 1 To 17
   
7.     For y = 1 To 4
   
8.         If arr(x, y) < 0 Then
   
9.             k = k + 1
   
10.             arr1(k, 1) = arr(x, y)
    
11.         End If
    
12.     Next y
    
13. Next x
    
14. Range("M1").Resize(m) = arr1
    
15. End Sub
    

复制代码

gaoshuichang1

13课作业.rar (6.74 KB, 下载次数: 5)

2012-4-29 21:03 上传

点击文件名下载附件

1. Sub aa()
   
2. Dim x As Integer, y As Integer, k As Integer, m As Integer
   
3. Dim arr, arr1(1 To 10000, 1 To 1)
   
4. arr = Range("a1:d17")
   
5. For x = 1 To 17
   
6.     For y = 1 To 4
   
7.         If arr(x, y) < 0 Then
   
8.            If arr(x, y) < 0 Then
   
9.             k = k + 1
   
10.             arr1(k, 1) = arr(x, y)
    
11.            End If
    
12.             arr(x, y) = 0
    
13.         End If
    
14.     Next y
    
15. Next x
    
16. Range("g1").Resize(17, 4) = arr
    
17. m = Application.CountIf(Range("a1:d17"), "<0")
    
18. Range("M1").Resize(m) = arr1
    
19. End Sub
    

复制代码

gaoshuichang1

13课作业.rar (7.85 KB, 下载次数: 3)

2012-4-30 06:18 上传

点击文件名下载附件

1. Sub aa()
   
2. Dim x As Integer, y As Integer, k As Integer
   
3. Dim arr, arr1(1 To 10000, 1 To 1)
   
4. arr = Range("a1:d17")
   
5. For x = 1 To 17
   
6.     For y = 1 To 4
   
7.         If arr(x, y) < 0 Then
   
8.            k = k + 1
   
9.            arr1(k, 1) = arr(x, y)
   
10.            arr(x, y) = 0
    
11.         End If
    
12.     Next y
    
13. Next x
    
14. Range("g1").Resize(17, 4) = arr
    
15. k = Application.CountIf(Range("a1:d17"), "<0")
    
16. Range("M1").Resize(k) = arr1
    
17. End Sub

复制代码

梅一枝

A06 梅一枝13讲v数组入门作业.zip (8.64 KB, 下载次数: 3)

2012-4-30 19:26 上传

点击文件名下载附件 A06：梅一枝  
作业改一下：
Sub 数组正确()
    Dim x As Integer
    Dim y As Integer
    Dim ARR
    ARR = Range("a1:d17")
    For x = 1 To 17
        For y = 1 To 4
            If ARR(x, y) < 0 Then
                ARR(x, y) = 0
            End If
        Next y
Next x
Range("g1:j17") = ARR
End Sub

Sub 数组负数()
    Dim x As Integer
    Dim y As Integer
    Dim ARR()
    ARR = Range("a1:d17")
    For x = 1 To 17
        For y = 1 To 4
            If ARR(x, y) < 0 Then
                Range("m" & Range("m65536").End(xlUp).Row + 1) = ARR(x, y)
            End If
        Next y, x
    End Sub

shengxudong

Sub 转换()
Dim x As Long, y As Long, k As Long
Dim xrows As Long, ycolumn As Long
Dim arr() As Double
Dim Arr1() As Double
'k = 0
xrows = Range("A1").End(xlDown).Row
ycolumn = Range("A1").End(xlToRight).Column
ReDim Preserve arr(1 To xrows, 1 To ycolumn)
For x = 1 To xrows
    For y = 1 To ycolumn
        If Cells(x, y).Value < 0 Then
            arr(x, y) = 0
            ReDim Preserve Arr1(k)
            Arr1(k) = Cells(x, y).Value
            k = k + 1
            arr(x, y) = 0
        Else
            arr(x, y) = Cells(x, y).Value
        
        End If
    Next y
    y = 1
Next x
For x = 1 To xrows
    For y = 1 To ycolumn
        Cells(x, y + 6).Value = arr(x, y)
    Next y
    y = 1
Next x

For x = 1 To k - 1
    Cells(x, y + 12).Value = Arr1(x)
Next x

End Sub

Sub 清除()
[g1:j17] = ""
[m1:m21] = ""

End Sub

zjyxp

13课作业_D09zjyxp.xls (39.5 KB, 下载次数: 2)

2012-5-1 13:21 上传

点击文件名下载附件
D09 zjyxp上次，请老师批改指导，十分感谢！
作业1

1. Sub 作业1()
   
2.     Dim x As Integer
   
3.     Dim arr
   
4.         arr = Range("a1:d17")
   
5.         For x = 1 To 17
   
6.             If arr(x, 1) < 0 Then arr(x, 1) = 0
   
7.             If arr(x, 2) < 0 Then arr(x, 2) = 0
   
8.             If arr(x, 3) < 0 Then arr(x, 3) = 0
   
9.             If arr(x, 4) < 0 Then arr(x, 4) = 0
   
10.         Next x
    
11.     Range("g1").Resize(17, 4) = arr
    
12. End Sub

复制代码

作业2

1. Sub 作业2()
   
2.     Dim y As Integer
   
3.     Dim k As Integer
   
4.     Dim arr
   
5.     Dim arr1(1 To 68, 1 To 1)
   
6.         arr = Range("a1:d17")
   
7.         For y = 1 To 17
   
8.             If arr(y, 1) < 0 Then
   
9.                 k = k + 1
   
10.             arr1(k, 1) = arr(y, 1)
    
11.             End If
    
12.             If arr(y, 2) < 0 Then
    
13.                 k = k + 1
    
14.             arr1(k, 1) = arr(y, 2)
    
15.             End If
    
16.             If arr(y, 3) < 0 Then
    
17.                 k = k + 1
    
18.             arr1(k, 1) = arr(y, 3)
    
19.             End If
    
20.             If arr(y, 4) < 0 Then
    
21.                 k = k + 1
    
22.             arr1(k, 1) = arr(y, 4)
    
23.             End If
    
24.         Next y
    
25.         Range("m1").Resize(68, 1) = arr1
    
26. End Sub

复制代码

兰色幻想

作业贴已打开，大家可以互相学习一下答案

mfksypss

迟到也要交！！！！！！
下次坚决不迟到