统计VBA学习小组正式组的积分帖之作业上交贴（第17周）

libenwen2011

16组：libenwen2011   (UID: 514207)

Sub 筛选()
Dim arr(), ar(), k, x, j, I, Y, z, xx
z = 5
I = Sheets("查询").Range("B2")
ar = Array(0, "A店", "B店", "C店")
Range("a5:d17") = " "
For Y = 1 To 3
    j = 1
    Sheets(ar(Y)).Select
    k = Application.CountIf(Sheets(ar(Y)).[B:B], I)
    ReDim arr(1 To k, 1 To 2)
    For x = 2 To Range("b65536").End(xlUp).Row
       If Cells(x, 2) = I Then
         arr(j, 1) = Cells(x, 1)
         arr(j, 2) = Cells(x, 3)
         Sheets("查询").Cells(z, 1) = ar(Y)
         Sheets("查询").Cells(z, 2) = arr(j, 1)
         Sheets("查询").Cells(z, 3) = I
         Sheets("查询").Cells(z, 4) = arr(j, 2)
         j = j + 1
         z = z + 1
       End If
    Next x
Next Y
Sheets("查询").Select
End Sub

chenzhi_juan

1. 
   
2. Sub 筛选()
   
3. Range("a5:d1000").Clear
   
4. Dim sheetcount As Integer, x As Integer, arr(1 To 10000, 1 To 4)
   
5. Dim k As Integer
   
6. For sheetcount = 1 To 3
   
7.      With Sheets(sheetcount)
   
8.        For x = 2 To .Range("a65536").End(xlUp).Row
   
9.          If .Cells(x, "b") = Range("b2") Then
   
10.             k = k + 1
    
11.             arr(k, 1) = .Name
    
12.             arr(k, 2) = .Cells(x, "a")
    
13.             arr(k, 3) = .Cells(x, "b")
    
14.             arr(k, 4) = .Cells(x, "c")
    
15.          End If
    
16.         Next x
    
17.      End With
    
18. Next sheetcount
    
19. Range("a5").Resize(k, 4) = arr
    
20. End Sub
    

复制代码

H19:chenzhi_juan

hactnet

来交下数组2作业！H组 H15:hactnet

Sub 筛选()
   
    Sheets("查询").Range("A5:D1000") = ""                       '筛选前清空
   
    Dim 店 As Integer
    Dim 店名, 品名
    Dim arr()                                                   '定义数组
    Dim k, X, j, y                                              '定义计数
   
    品名 = Sheets("查询").Range("B2")                           '要筛选的值
   
    For 店 = 1 To Sheets.Count                                  '计算表总数
   
        店名 = Sheets(店).Name                                  '表名赋给变量
        
        If Sheets(店).Name Like "*店" Then                      '判断表名是否含"店"
        
        k = Application.CountIf(Sheets(店).[b:b], 品名)         '统计单内符合条件的品名数
        
        If k = 0 Then                                           '判断K值，防止K值为0时数组出错
            k = k + 1
        Else
            k = k
        End If
        
            j = 1
        ReDim arr(1 To k, 1 To 4)                                   '跟据符合条件的品名数重新定义数组大小
        
            For X = 2 To Sheets(店).Range("A65536").End(xlUp).Row   '循环把符合品名条件的数据赋予数组
                If Sheets(店).Cells(X, 2) = 品名 Then
                    arr(j, 1) = 店名
                    arr(j, 2) = Sheets(店).Cells(X, 1)
                    arr(j, 3) = Sheets(店).Cells(X, 2)
                    arr(j, 4) = Sheets(店).Cells(X, 3)
                    j = j + 1
                End If
            Next X
            y = Sheets("查询").Range("A65536").End(xlUp).Row + 1    '指定数组数据写出位置
            Sheets("查询").Range("A" & y).Resize(k, 4) = arr()      '把数组数据写出到指定位置
        End If
    Next 店

End Sub

byhdch

A09:byhdch       请老师批改作业
Sub 筛选()
    Dim arr1(), arr2(), arr3(), arr4()
    Dim rg As Range, i, k As Integer
    Sheets("查询").Select
    For i = 1 To Sheets.Count
        If Sheets(i).Name <> "查询" Then
            With Sheets(i)
                For Each rg In .Range("b2:b" & .Range("b65536").End(xlUp).Row)
                    If rg = Sheets("查询").Range("b2") Then
                        k = k + 1
                        ReDim Preserve arr1(1 To 1, 1 To k)
                        ReDim Preserve arr2(1 To 1, 1 To k)
                        ReDim Preserve arr3(1 To 1, 1 To k)
                        ReDim Preserve arr4(1 To 1, 1 To k)
                        arr1(1, k) = rg.Offset(0, -1)
                        arr2(1, k) = rg
                        arr3(1, k) = rg.Offset(0, 1)
                        arr4(1, k) = Sheets(i).Name
                    End If
                Next rg
            End With
        End If
    Next i
    With Sheets("查询")
        .Range("a5:d" & Range("a65536").End(xlUp).Row) = ""
        .Range("b5").Resize(k) = Application.Transpose(arr1)
        .Range("c5").Resize(k) = Application.Transpose(arr2)
        .Range("d5").Resize(k) = Application.Transpose(arr3)
        .Range("a5").Resize(k) = Application.Transpose(arr4)
    End With
End Sub

第14课作业 A09byhdch.rar (13.36 KB, 下载次数: 6)

2012-5-10 22:21 上传

点击文件名下载附件

兰江自由鱼

我的作业如下，请批改。谢谢！ D15兰江自由鱼_第14课作业.rar (10.8 KB, 下载次数: 6)

2012-5-10 23:02 上传

点击文件名下载附件

Sub 筛选()
    Dim Arr_S1, Arr_S2, Arr_S3
    Dim Arr_T(1000, 3)
    Dim i&, j&
    Dim str As String
    str = Range("B2")
    Arr_S1 = Sheet1.Range("A2:C" & Sheet1.Range("C65535").End(xlUp).Row).Value
    Arr_S2 = Sheet2.Range("A2:C" & Sheet2.Range("C65535").End(xlUp).Row).Value
    Arr_S3 = Sheet3.Range("A2:C" & Sheet3.Range("C65535").End(xlUp).Row).Value
    For i = 1 To UBound(Arr_S1)
        If Arr_S1(i, 2) = str Then
            Arr_T(j, 0) = "A店"
            Arr_T(j, 1) = Arr_S1(i, 1)
            Arr_T(j, 2) = Arr_S1(i, 2)
            Arr_T(j, 3) = Arr_S1(i, 3)
            j = j + 1
        End If
    Next i
    For i = 1 To UBound(Arr_S2)
        If Arr_S2(i, 2) = str Then
            Arr_T(j, 0) = "B店"
            Arr_T(j, 1) = Arr_S2(i, 1)
            Arr_T(j, 2) = Arr_S2(i, 2)
            Arr_T(j, 3) = Arr_S2(i, 3)
            j = j + 1
        End If
    Next i
    For i = 1 To UBound(Arr_S3)
        If Arr_S3(i, 2) = str Then
            Arr_T(j, 0) = "C店"
            Arr_T(j, 1) = Arr_S3(i, 1)
            Arr_T(j, 2) = Arr_S3(i, 2)
            Arr_T(j, 3) = Arr_S3(i, 3)
            j = j + 1
        End If
    Next i
    Range("A5:D1000").ClearContents
    Range("A5").Resize(j, 4) = Arr_T
End Sub

1982zyh

Sub 筛选()

Dim i As Integer, m As Integer, n As Integer, x As Integer
Dim str As String
Dim arr, arr1(1 To 100000, 1 To 4)

str = ActiveSheet.Range("b2")
n = ActiveSheet.Range("a65536").End(xlUp).Row
Rows("5:" & n).Delete
x = 1
For i = 1 To Sheets.Count

    If Sheets(i).Name <> "查询" Then

        arr = Sheets(i).Range("a1").CurrentRegion

        For m = 2 To UBound(arr, 1)

            If arr(m, 2) = str Then

                arr1(x, 1) = Sheets(i).Name
                arr1(x, 2) = arr(m, 1)
                arr1(x, 3) = str
                arr1(x, 4) = arr(m, 3)
                x = x + 1

            End If

        Next m

    End If

Next i

Sheets("查询").Range("a5").Resize(x, 4) = arr1

End Sub

szczm121

g17:szczm121 第14课作业SZCZM121.rar (14.97 KB, 下载次数: 2)

2012-5-12 16:18 上传

点击文件名下载附件
Sub 筛选()
Dim X As Integer, Y As Integer, C As Integer, Z As Integer
Dim NA As String, NA1 As String, NA2 As String
Dim W As Long, W1 As Long, W2 As Long, W3 As Long, K As Integer
Dim ARR(1 To 30000, 1 To 4), ARR1(1 To 10000, 1 To 4), ARR2
Sheets("查询").Range("A5:D63556") = ""
ARR2 = Sheets("查询").Range("B2")
NA = Sheets("A店").Name
NA1 = Sheets("B店").Name
NA2 = Sheets("C店").Name
X = Sheets("A店").Range("a65536").End(xlUp).Row
Y = Sheets("B店").Range("a65536").End(xlUp).Row
C = Sheets("C店").Range("a65536").End(xlUp).Row
  For W = 2 To X
    For W1 = 1 To 3
      ARR(W - 1, W1 + 1) = Sheets("A店").Cells(W, W1)
      ARR(W - 1, 1) = NA
    Next W1
  Next W
  For W2 = 2 To Y
    For W1 = 1 To 3
      ARR(W + W2 - 3, W1 + 1) = Sheets("B店").Cells(W2, W1)
      ARR(W + W2 - 3, 1) = NA1
    Next W1
  Next W2
  For W3 = 2 To C
    For W1 = 1 To 3
      ARR(W + W2 + W3 - 5, W1 + 1) = Sheets("C店").Cells(W3, W1)
      ARR(W + W2 + W3 - 5, 1) = NA2
    Next W1
  Next W3
  For Z = 1 To UBound(ARR)
    If ARR(Z, 3) = ARR2 Then
      K = K + 1
      ARR1(K, 1) = ARR(Z, 1)
      ARR1(K, 2) = ARR(Z, 2)
      ARR1(K, 3) = ARR(Z, 3)
      ARR1(K, 4) = ARR(Z, 4)
    End If
  Next Z
Sheets("查询").Range("a5:d10000") = ARR1
End Sub

mfksypss

辛苦校长了～～～～～～～～～～

bikong01

Sub 筛选()
Dim x As Integer, y As Integer, k, arr(1 To 10000, 1 To 4)
     Range("a5:d1000") = ""
       For x = 1 To Sheets.Count - 1
         With Sheets(x)
           For y = 1 To .Range("a65536").End(xlUp).Row
             If .Cells(y, 2) = Sheets(4).Range("b2") Then
              k = k + 1
              arr(k, 1) = .Name
              arr(k, 2) = .Cells(y, 1)
              arr(k, 3) = .Cells(y, 2)
              arr(k, 4) = .Cells(y, 3)
             End If
           Next y
         End With
       Next x
     Sheets("查询").Range("a5").Resize(k, 4) = arr
End Sub

yijundanny

[/hide]
校长辛苦了！
[hide]