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

想飞的鸟

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

从从容容

D03 从从容容

Sub 第一题()
Dim arr(1 To 17, 1 To 4)
Dim arry
Dim m, n, k As Integer
arry = Range("a1:d17")
For m = 1 To UBound(arry, 1)
  For n = 1 To UBound(arry, 2)
   If arry(m, n) < 0 Then
     arry(m, n) = 0
   End If
     arr(m, n) = arry(m, n)
     Cells(m, n + 6) = arr(m, n)
  Next n
Next m
End Sub
Sub 第二题()
Dim arr1
Dim arr2(1 To 1000, 1 To 1)
Dim m, n, k As Integer
k = 1
  arr1 = Range("a1:d17")
  For m = 1 To UBound(arr1, 1)
   For n = 1 To UBound(arr1, 2)
     If arr1(m, n) < 0 Then
       arr2(k, 1) = arr1(m, n)
       Cells(k, "m") = arr2(k, 1)
       k = k + 1
     End If
   Next n
  Next m
End Sub
13课作业.rar (9.81 KB, 下载次数: 3)

2012-4-27 07:39 上传

点击文件名下载附件

yl_li

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

2012-4-27 09:37 上传

点击文件名下载附件
Sub aa()
Dim arr, arr1(1 To 17, 1 To 4), arr2(1 To 100), i, j, k
arr = Range("a1:d17")
k = 1
    For i = 1 To UBound(arr, 1)
        For j = 1 To UBound(arr, 2)
            If arr(i, j) < 0 Then
                arr1(i, j) = 0
                arr2(k) = arr(i, j)
                k = k + 1
            Else
                arr1(i, j) = arr(i, j)
            End If
        Next j
    Next i
    Range("g1:j17") = arr1
    Range("m1").Resize(k) = WorksheetFunction.Transpose(arr2)
End Sub

sliang28

C09:sliang28

1. Private Sub CommandButton1_Click()
   
2. 
   
3. Dim i, j, k As Integer
   
4. 
   
5. Dim arr(1 To 17, 1 To 4)
   
6. Dim arr1(1 To 100)
   
7. 
   
8. k = 1
   
9. For i = 1 To 17
   
10.    
    
11.    For j = 1 To 4
    
12.    
    
13.      If Cells(i, j) >= 0 Then
    
14.       
    
15.        arr(i, j) = Cells(i, j)
    
16.         
    
17.          Else
    
18.             
    
19.             arr1(k) = Cells(i, j)
    
20.                
    
21.                k = k + 1
    
22.             
    
23.                   arr(i, j) = 0
    
24.    
    
25.        End If
    
26.    
    
27.    Next
    
28. 
    
29. Next
    
30.    
    
31.     [G1:J17] = arr
    
32.    
    
33.     [M1:M100] = WorksheetFunction.Transpose(arr1)
    
34. 
    
35. End Sub
    

复制代码

liuho1

Sub 十三课()
Dim ARR, x As Integer, y As Integer, a As Integer
Dim arr1(1 To 1000, 1 To 1)
   a = 0
ARR = Range("a1:d17")
For x = 1 To UBound(ARR)
   For y = 1 To UBound(ARR, 2)
     If ARR(x, y) < 0 Then
     a = a + 1
      arr1(a, 1) = ARR(x, y)
      ARR(x, y) = 0
    End If
   Next y
Next x
Range("g1:j17") = ARR
Range("m1").Resize(a + 1, 1) = arr1
End Sub

sunjing-zxl

13课作业-E学委-sunjing-zxl.rar (10.07 KB, 下载次数: 6)

2012-4-27 16:06 上传

点击文件名下载附件

1. Sub 作业13_sunjing_zxl()
   
2.     Dim arr, arr1
   
3.     Dim i As Long, j As Long
   
4.     Dim m As Long
   
5.     arr = Range("A1:D" & [A65536].End(xlUp).Row)
   
6.     ReDim arr1(1 To UBound(arr) * UBound(arr, 2), 1 To 1)
   
7.     For i = 1 To UBound(arr)
   
8.         For j = 1 To UBound(arr, 2)
   
9.             If arr(i, j) < 0 Then
   
10.                 m = m + 1
    
11.                 arr1(m, 1) = arr(i, j)
    
12.                 arr(i, j) = 0
    
13.             End If
    
14.         Next j
    
15.     Next i
    
16.     Range("G1:M" & [M65536].End(xlUp).Row + 1).ClearContents
    
17.     Range("G1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
18.     Range("M1").Resize(UBound(arr1), UBound(arr1, 2)) = arr1
    
19. End Sub
    

复制代码

hactnet

来交作业校长幸苦！H组-H15:hactnet
Sub test()

Dim x As Integer, y As Integer, k As Integer
Dim arr
Dim arr1(1 To 1000, 1 To 1)

arr = Range("A1:D17")
k = 1
   
    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
            arr(x, y) = 0
        End If
        Next y
    Next x

Range("G1:J17") = ""
'Range("G1:J17") = arr
Range("G1").Resize(UBound(arr), UBound(arr, 2)) = arr
Range("M1").Resize(UBound(arr1), 1) = arr1

End Sub

byhdch

A09:byhdch

1. 
   
2. 
   
3. Sub 负数转零()
   
4.     Dim arr, x, y As Integer
   
5.     arr = Range("a1:d17")
   
6.     For x = 1 To UBound(arr)
   
7.         For y = 1 To UBound(arr, 2)
   
8.             If arr(x, y) < 0 Then arr(x, y) = 0
   
9.         Next y
   
10.     Next x
    
11.     Range("g1").Resize(17, 4) = arr
    
12. End Sub
    
13. 
    
14. Sub 负数排列()
    
15.     Dim arr, arr1(1 To 10000, 1 To 1)
    
16.     Dim x, y, k As Integer
    
17.     arr = Range("a1:d17")
    
18.     For x = 1 To UBound(arr)
    
19.         For y = 1 To UBound(arr, 2)
    
20.             If arr(x, y) < 0 Then
    
21.                 k = k + 1
    
22.                 arr1(k, 1) = arr(x, y)
    
23.             End If
    
24.         Next y
    
25.     Next x
    
26.     Range("m1").Resize(k) = arr1
    
27. End Sub

复制代码

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

2012-4-27 21:39 上传

点击文件名下载附件

dsjohn

Sub 要求一()
Dim Rg As Range
For Each Rg In Range("A1:D17")
If Rg > 0 Then
    Rg = Rg
Else
    Rg = 0
End If
Next Rg
    Range("A1:D17").Copy Range("G1")
End Sub
Sub 要求二()
Dim arr1(1 To 1000, 1 To 1)
Dim arr
Dim X, Y, K
arr = Range("a1:d17")
For X = 1 To UBound(arr, 1)
    For Y = 1 To UBound(arr, 2)
        If arr(X, Y) < 0 Then
            K = K + 1
            arr1(K, 1) = arr(X, Y)
        End If
Next Y, X
    Range("m1").Resize(K, 1) = arr1
End Sub