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

冠军欧洲2010

说明:
统计帖每个学员只能跟帖回复一次，也就是在原来回复楼层的基础上点编缉，不要一个链接一层楼，否则不计算积分。
各小组学员上交作业时，一定要点击“我要参加”，并注明自己的新组编号和论坛ID，如果点击过“我要参加”但没有跟帖提交作业的，扣该学员5积分；如果跟帖提交了作业，但没有点“我要参加”的，不给予评分。

请各学员看清上面的说明，免得被扣了分分！
本帖为仅楼主可见帖，直接回复即可！
作业链接：http://www.excelpx.com/thread-239652-1-1.html

hrpotter

C12:hrpotter

1. Sub 转换填充()
   
2.     Dim ar, br(1 To 10000, 1 To 1)
   
3.     Dim i As Integer, j As Integer, k As Integer
   
4.     ar = Range("a1").CurrentRegion
   
5.     For i = 1 To UBound(ar)
   
6.         For j = 1 To UBound(ar, 2)
   
7.             If ar(i, j) < 0 Then
   
8.                 k = k + 1
   
9.                 br(k, 1) = ar(i, j)
   
10.                 ar(i, j) = 0
    
11.             End If
    
12.         Next
    
13.     Next
    
14.     Range("g:m").ClearContents
    
15.     Range("g1").Resize(UBound(ar), UBound(ar, 2)) = ar
    
16.     If k > 0 Then Range("m1").Resize(k, 1) = br
    
17. End Sub

复制代码

C12-hrpotter-13课作业.rar (10.26 KB, 下载次数: 52)

2012-4-26 14:31 上传

点击文件名下载附件

冠军欧洲2010

1. Sub a()
   
2. Dim x, y, k As Long
   
3. Dim arr
   
4. Dim arr1(1 To 100000, 1 To 1)
   
5. arr = Range("a1:d17")
   
6. For x = 1 To UBound(arr)
   
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. arr(x, y) = 0
    
12. End If
    
13. Next y
    
14. Next x
    
15. Range("g1").Resize(17, 4) = arr
    
16. Range("m1").Resize(k, 1) = arr1
    
17. End Sub
    

复制代码

wenchduan

A组长：wenchduan

1. Sub 数组作业题1()
   
2. Dim ARR, X As Integer, y As Integer
   
3. ARR = Range("a1:D17")
   
4. For X = 1 To UBound(ARR)
   
5.    For y = 1 To UBound(ARR, 2)
   
6.         If ARR(X, y) < 0 Then ARR(X, y) = 0
   
7.    Next y
   
8. Next X
   
9. Range("G1").Resize(17, 4) = ARR
   
10. End Sub
    
11. Sub 数组作业题2()
    
12. Dim arr1(1 To 10000, 1 To 1), k%
    
13. Dim ARR, X As Integer, y As Integer
    
14. ARR = Range("a1:D17")
    
15. For X = 1 To UBound(ARR)
    
16.    For y = 1 To UBound(ARR, 2)
    
17.         If ARR(X, y) < 0 Then
    
18.           k = k + 1
    
19.           arr1(k, 1) = ARR(X, y)
    
20.         End If
    
21.    Next y
    
22. Next X
    
23. Range("m1").Resize(k, 1) = arr1
    
24. End Sub
    

复制代码

zjcat35

E02:zjcat35

1. Sub text()
   
2.     Dim arr, br(1 To 10000, 1 To 1)
   
3.     Dim i As Byte, j As Byte, k As Byte
   
4.     arr = Range("a1").CurrentRegion
   
5.     For i = 1 To UBound(arr, 1)
   
6.         For j = 1 To UBound(arr, 2)
   
7.             If arr(i, j) < 0 Then
   
8.                 k = k + 1
   
9.                 br(k, 1) = arr(i, j)
   
10.                 arr(i, j) = 0
    
11.             End If
    
12.         Next j
    
13.     Next i
    
14.     Range("g1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    
15.     Range("m:m").ClearContents
    
16.     Range("m1").Resize(k) = br
    
17. End Sub
    

复制代码

我不知道呀

Sub 第一题()
    Dim x As Integer, y As Integer
    Dim arr
    arr = Range("a1:g17")
    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
    [g1].Resize(17, 4) = arr
   End Sub
'--------------------------------------------
Sub 第二题()
    Dim arr1(1 To 10000, 1 To 1)
    Dim arr
    Dim k As Integer,x As Integer, y As Integer
    arr = Range("a1:g17")
    k = 1
    For x = 1 To 17
        For y = 1 To 4
            If arr(x, y) < 0 Then
                arr1(k, 1) = arr(x, y)
                k = k + 1
            End If
        Next y
    Next x
    [m1].Resize(10000, 1) = arr1
End Sub

lslly

13课作业.rar (9.98 KB, 下载次数: 2)

2012-4-26 19:38 上传

点击文件名下载附件

qushui

A组学委qushui

1. Sub 十三课作业()
   
2. Dim arr, brr(1 To 17, 1 To 4), crr(1 To 100, 1 To 1), i%, j%, k%
   
3. arr = Range("a1:d17").Value
   
4. For i = 1 To 17
   
5. For j = 1 To 4
   
6. If arr(i, j) < 0 Then
   
7. brr(i, j) = 0
   
8. k = k + 1
   
9. crr(k, 1) = arr(i, j)
   
10. Else
    
11. brr(i, j) = arr(i, j)
    
12. End If
    
13. Next j
    
14. Next i
    
15. Range("g1:j17") = brr
    
16. Range("m1").Resize(k) = crr
    
17. End Sub
    

复制代码

想飞的鸟

Sub 更换()
Dim tg
Dim x, y, k As Integer
k = 1

tg = Range("a1:d17")
  For x = 1 To UBound(tg)
      For y = 1 To UBound(tg, 2)
          If Cells(x, y) < 0 Then
          Range("m" & k) = Cells(x, y)
          k = k + 1
          tg(x, y) = 0
      End If
      Next y
      Next x

      Range("g1:j13") = ""
      Range("g1").Resize(UBound(tg), UBound(tg, 2)) = tg



End Sub

想飞的鸟

这是第二种做法：

Sub 更换1()
Dim arr1(1 To 100, 1 To 1)
Dim tg
Dim x, y, k As Integer
k = 1
tg = Range("a1:d17")
  For x = 1 To UBound(tg)
      For y = 1 To UBound(tg, 2)
          If Cells(x, y) < 0 Then
          arr1(k, 1) = tg(x, y)
          k = k + 1
          tg(x, y) = 0
      End If
      Next y
      Next x

      Range("g1:j13") = ""
      Range("g1").Resize(UBound(tg), UBound(tg, 2)) = tg
     Range("m1").Resize(UBound(arr1), UBound(arr1, 2)) = arr1


End Sub