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

szczm121

g17:szczm121   13课作业g17-szczm121.rar (9.15 KB, 下载次数: 4)

2012-4-27 23:47 上传

点击文件名下载附件
Sub 一次性装入()
Dim arr, arr1(1 To 10000, 1 To 1), 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
          k = k + 1
          arr1(k, 1) = arr(x, y)
          arr(x, y) = 0
        End If
      Next y
    Next x
Range("g1:j17") = arr
Range("m1:m10000") = arr1
End Sub
Sub 循环装入()
Dim arr(1 To 17, 1 To 4), arr1(1 To 10000, 1 To 1), x As Integer, y As Integer
  For x = 1 To 17
    For y = 1 To 4
    arr(x, y) = Cells(x, y)
      If arr(x, y) < 0 Then
        k = k + 1
        arr1(k, 1) = arr(x, y)
        arr(x, y) = 0
      End If
    Next y
  Next x
Range("g1:j17") = arr
Range("m1:m10000") = arr1
End Sub

w2001pf

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

2012-4-28 09:55 上传

点击文件名下载附件
Sub T13KSZ1()
  Dim arr
  Dim 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
     Else
       arr(x, y) = arr(x, y)
     End If
    Next y
  Next x
Range("G1：J17") = arr
End Sub


Sub T13KSZ2()
  Dim arr
  Dim x As Integer, k As Integer, y
  Dim arr1(1 To 1000, 1 To 1)
  arr = Range("a1:d17")
   For y = 1 To UBound(arr)
    For x = 1 To UBound(arr, 2)
        If arr(y, x) < 0 Then
         k = k + 1
          arr1(k, 1) = arr(y, x)
         End If
    Next x
  Next y
Range("m1：m" & k) = arr1
End Sub

开心妙妙

13课作业-B09开心妙妙.rar (10.7 KB, 下载次数: 3)

2012-4-28 13:32 上传

点击文件名下载附件
Sub 数组13讲2()
          Dim x As Integer, y As Integer, n As Integer   '行变量,列变量,负数个数
          Dim arr
          Dim arr1()
1         Range("G1:J" & Range("G65536").End(xlUp).Row) = ""
2         Range("M1:M" & Range("M65536").End(xlUp).Row) = ""
3         arr = Range("A1:D17")
4         For x = 1 To 17
5             For y = 1 To 4
6                 If arr(x, y) < 0 Then
7                     n = n + 1
8                     ReDim Preserve arr1(1 To n)
9                     arr1(n) = arr(x, y)
10                    arr(x, y) = 0
11                End If
12            Next y
13        Next x
14        Range("G1").Resize(x - 1, y - 1) = arr
15        Range("M1").Resize(n) = Application.Transpose(arr1)
End Sub

libenwen2011

16组:libenwen2011  (UID: 514207)

Sub 第13课数组作业()
  Dim x As Long, y As Long, h
  Dim arr(1 To 17, 1 To 4)
  h = 0
  For x = 1 To 17
    For y = 1 To 4
       arr(x, y) = Cells(x, y)
       Cells(x, y + 6) = arr(x, y) '要求1
       If arr(x, y) < 0 Then
          Cells(x, y + 6) = 0
       End If
       If arr(x, y) < 0 Then '要求2： 把负数全部显示到M列
          h = h + 1
          Range("m" & h) = arr(x, y)
       End If
     Next y
  Next x
End Sub

Iweb

收获源自积累，坚持终能成长！

vbamaster

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

2012-4-28 20:42 上传

点击文件名下载附件
Sub s1()
    Dim arr, arr1()
    Dim x, y, k As Integer
    arr = Range("a1:d17")
    For x = 1 To UBound(arr, 1)
        For y = 1 To UBound(arr, 2)
            If arr(x, y) < 1 Then
                k = k + 1
                ReDim Preserve arr1(1 To k)
                arr1(k) = arr(x, y)
                arr(x, y) = 0
            End If
        Next y
    Next x
    Range("g1:j17") = arr
    Range("m1:m" & k) = Application.WorksheetFunction.Transpose(arr1)
End Sub
D05:vabmaster

兰江自由鱼

作业已完成，请批改。谢谢！
Sub 兰江自由鱼()
    Dim arr, arr_t(1 To 10000, 1 To 1)
    Dim i As Integer, j As Integer, k As Integer
    arr = Range("A1:D17").Value
    k = 1
    For i = 1 To UBound(arr, 1)
        For j = 1 To UBound(arr, 2)
            If arr(i, j) < 0 Then
                arr_t(k, 1) = arr(i, j)
                arr(i, j) = 0
                k = k + 1
            End If
        Next j
    Next i
    Range("G1:J17").ClearContents
    Range("G1:J17") = arr
    Range("M:M").ClearContents
    Range("M1").Resize(k, 1) = arr_t
End Sub
D15兰江自由鱼_13课作业.rar (9.84 KB, 下载次数: 2)

2012-4-28 21:04 上传

点击文件名下载附件

1982zyh

1. Sub test()
   
2. 
   
3. Dim arr, arr1(1 To 10000, 1 To 1)
   
4. 
   
5. Dim m As Integer, n As Integer, k As Integer
   
6. 
   
7. k = 0
   
8. 
   
9. arr = Sheets("Sheet1").Range("A1").CurrentRegion
   
10. 
    
11. For m = 1 To UBound(arr, 2)
    
12. 
    
13.     For n = 1 To UBound(arr, 1)
    
14.         
    
15.         If arr(n, m) < 0 Then
    
16.         
    
17.             k = k + 1
    
18.         
    
19.             arr1(k, 1) = arr(n, m)
    
20.         
    
21.             arr(n, m) = 0
    
22.                     
    
23.         End If
    
24.    
    
25.     Next n
    
26. 
    
27. Next m
    
28. 
    
29. Range("g1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    
30. 
    
31. Range("m1").Resize(k, 1) = arr1
    
32. 
    
33. End Sub

复制代码

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

2012-4-28 22:28 上传

点击文件名下载附件

yijundanny

b11:yijundanny                       

jxncfxsf

Sub aa()
Dim m, n, i As Long
Dim arr, arr1()
Dim str As String
arr = Range("a1:d17")
For m = 1 To UBound(arr)
For n = 1 To 4
If arr(m, n) < 0 Then
ReDim Preserve arr1(0, i)
  str = arr(m, n)
arr1(0, i) = arr(m, n)
  arr(m, n) = 0
   i = i + 1
  End If
  Next n
  Next m
  Range("g1").Resize(UBound(arr), 4) = arr
  Range("m1").Resize(i) = Application.Transpose(arr1)
End Sub