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

冠军欧洲2010

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

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

hrpotter

C12:hrpotter

1. Sub 筛选()
   
2.     Dim ar, br(1 To 10000, 1 To 4)
   
3.     Dim i As Integer, j As Integer, k As Integer
   
4.     Dim s As String
   
5.     s = Range("b2")
   
6.     For i = 1 To 3
   
7.         ar = Sheets(i).Range("a1").CurrentRegion
   
8.         For j = 2 To UBound(ar)
   
9.             If ar(j, 2) = s Then
   
10.                 k = k + 1
    
11.                 br(k, 1) = Sheets(i).Name
    
12.                 br(k, 2) = ar(j, 1)
    
13.                 br(k, 3) = ar(j, 2)
    
14.                 br(k, 4) = ar(j, 3)
    
15.             End If
    
16.         Next
    
17.     Next
    
18.     Range("a5:d65536").Clear
    
19.     If k > 0 Then Range("a5").Resize(k, 4) = br
    
20. End Sub

复制代码

C12-hrpotter-第14课作业.rar (10.43 KB, 下载次数: 20)

2012-5-9 15:05 上传

点击文件名下载附件

yl_li

Sub 筛选()
Dim arr(1 To 100, 1 To 4), i As Integer, j As Integer, sh As Worksheet
Sheets("查询").Range("a5:d100").Clear
j = 1
    For Each sh In ThisWorkbook.Sheets
        If sh.Name <> "查询" Then
            For i = 2 To sh.Range("a" & Rows.Count).End(xlUp).Row
                If sh.Range("b" & i) = Sheets("查询").Range("b2") Then
                    arr(j, 1) = sh.Name
                    arr(j, 2) = sh.Range("a" & i)
                    arr(j, 3) = sh.Range("b" & i)
                    arr(j, 4) = sh.Range("c" & i)
                    j = j + 1
                End If
            Next i
        End If
    Next sh
    Sheets("查询").Range("a5").Resize(j - 1, 4) = arr
End Sub
第14课作业——B19：yl_li.rar (10.6 KB, 下载次数: 8)

2012-5-9 16:34 上传

点击文件名下载附件

从从容容

Sub 筛选()
Dim arr()
Dim x, j, k
Sheets("查询").Range("a5:d" & Sheets("查询").Range("a65536").End(3).Row).ClearContents

For x = 1 To Sheets.Count - 1
  Do
  j = j + 1
   If Sheets(x).Cells(j, 2) = Sheets("查询").[b2] Then
   k = k + 1
   ReDim Preserve arr(1 To 4, 1 To k)
   arr(1, k) = Sheets(x).Name
   arr(2, k) = Sheets(x).Cells(j, 1)
   arr(3, k) = Sheets(x).Cells(j, 2)
   arr(4, k) = Sheets(x).Cells(j, 3)
   End If
  Loop Until j = Sheets(x).Range("a65536").End(3).Row
  j = 0
  Next x
  Sheets("查询").Range("a5").Resize(UBound(arr, 2), 4) = Application.Transpose(arr)
End Sub

w2001pf

第14课作业.rar (11.37 KB, 下载次数: 3)

2012-5-9 20:40 上传

点击文件名下载附件 Sub 筛选()

Dim i As Integer, t, m, j
Dim k As Integer
Dim arr(1 To 100, 1 To 1)
Dim arr1(1 To 100, 1 To 3)
Sheets("查询").Range("a" & 5, "d" & Range("a65536").End(xlUp).Row) = ""
Application.ScreenUpdating = False
For i = 1 To 3
    With Sheets(i)
        t = .Range("a65536").End(xlUp).Row
            For m = 2 To t
                If .Range("b" & m) = Sheets("查询").Range("b2") Then
                     k = k + 1
                    arr(k, 1) = Sheets(i).Name
                    Sheets("查询").Range("a" & 5, "a" & 5 + k) = arr
                        For j = 1 To 3
                            arr1(k, j) = .Cells(m, j)
                         Next j
                    Sheets("查询").Range("b" & 5, "d" & 5 + k) = arr1

                End If
            Next m
    End With
Next i
Application.ScreenUpdating = True
End Sub

我不知道呀

Sub 查询()
    Dim sht As Worksheet
    Dim arr, x As Integer, y As Integer, x1 As Integer, x2 As Integer, i As Integer
    Dim arr1(1 To 100, 1 To 4)
    Dim arr2(1 To 100, 1 To 4)
    x1 = 1
    x2 = 1
    For Each sht In Sheets
        If sht.Name <> "查询" Then
            arr = sht.Range("a2:c" & sht.Range("a65536").End(xlUp).Row)
            For x = 1 To UBound(arr)
                For y = 1 To 3
                    arr1(x1, y + 1) = arr(x, y)
                    arr1(x1, 1) = sht.Name
                Next y
                x1 = x1 + 1
            Next x
        End If
        Erase arr
    Next
    For i = 1 To 100
        If arr1(i, 3) = Sheets("查询").Range("b2").Value Then
            For y = 1 To 4
                arr2(x2, y) = arr1(i, y)
            Next y
            x2 = x2 + 1
        End If
    Next i
     Sheets("查询").Range("a5:d100").ClearContents
     Sheets("查询").Range("a5").Resize(UBound(arr2), 4) = arr2
End Sub

sunjing-zxl

E学委:sunjing-zxl 上交第14课作业
第14课作业-E学委-sunjing-zxl.rar (11.96 KB, 下载次数: 6)

2012-5-9 22:18 上传

点击文件名下载附件

1. Sub 筛选()
   
2.     Dim arr(), arr1
   
3.     Dim i As Long, j As Long, k As Long
   
4.     Dim n As Long, m As Long
   
5.     Dim str As String
   
6.     For i = 1 To Sheets.Count
   
7.         If Sheets(i).Name Like "*店" Then
   
8.             n = n + 1
   
9.             ReDim Preserve arr(1 To n)
   
10.             arr(n) = Sheets(i).Range("A2:C" & Sheets(i).[A65536].End(xlUp).Row)
    
11.             arr(n) = Array(arr(n), Sheets(i).Name)
    
12.             m = m + UBound(arr(n)(0))
    
13.         End If
    
14.     Next i
    
15.     str = Cells(2, 2)
    
16.     ReDim arr1(1 To m, 1 To 4)
    
17.     m = 0
    
18.     For i = 1 To n
    
19.         For j = 1 To UBound(arr(i)(0))
    
20.             If arr(i)(0)(j, 2) = str Then
    
21.                 m = m + 1
    
22.                 arr1(m, 1) = arr(i)(1)
    
23.                 For k = 1 To 3
    
24.                     arr1(m, k + 1) = arr(i)(0)(j, k)
    
25.                 Next k
    
26.             End If
    
27.         Next j
    
28.     Next i
    
29.     Range("A5:D" & [A65536].End(xlUp).Row + 1).ClearContents
    
30.     Range("A5").Resize(UBound(arr1), 4) = arr1
    
31. End Sub
    

复制代码

ls

h22 ls 第14课作业.rar (8.43 KB, 下载次数: 20)

2012-5-9 23:52 上传

点击文件名下载附件

jxncfxsf

Sub 筛选()
Dim arr1, arr2, arr3, arr(), ar()
Dim m, n, i, k, q, H, j As Long
arr1 = Sheets("A店").Range("a2:c" & Sheets("A店").Range("c" & Rows.Count).End(3).Row)
arr2 = Sheets("B店").Range("a2:c" & Sheets("B店").Range("c" & Rows.Count).End(3).Row)
arr3 = Sheets("C店").Range("a2:c" & Sheets("C店").Range("c" & Rows.Count).End(3).Row)
k = UBound(arr1) + UBound(arr2) + UBound(arr3)
ReDim arr(1 To k, 1 To 4)
  For m = 1 To UBound(arr1)
  arr(m, 1) = "A店"
  arr(m, 2) = arr1(m, 1)
  arr(m, 3) = arr1(m, 2)
  arr(m, 4) = arr1(m, 3)
   Next m
  For n = 1 To UBound(arr2)
   arr(m + n - 1, 1) = "B店"
   arr(m + n - 1, 2) = arr2(n, 1)
   arr(m + n - 1, 3) = arr2(n, 2)
   arr(m + n - 1, 4) = arr2(n, 3)
   Next n
   For i = 1 To UBound(arr3)
   arr(m + n + i - 2, 1) = "C店"
   arr(m + n + i - 2, 2) = arr3(i, 1)
   arr(m + n + i - 2, 3) = arr3(i, 2)
   arr(m + n + i - 2, 4) = arr3(i, 3)
   Next i
   H = Application.CountIf(Sheets("A店").Range("B:B"), Range("b2")) + _
       Application.CountIf(Sheets("B店").Range("B:B"), Range("b2")) + _
       Application.CountIf(Sheets("C店").Range("B:B"), Range("b2"))
   ReDim ar(1 To H, 1 To 4)
   
For q = 1 To UBound(arr)

   If arr(q, 3) = Range("b2").Value Then
    j = j + 1
    ar(j, 1) = arr(q, 1)
    ar(j, 2) = arr(q, 2)
    ar(j, 3) = arr(q, 3)
    ar(j, 4) = arr(q, 4)
   End If
  Next q
  Range("a5:d" & Range("d" & Rows.Count).End(xlUp).Row).ClearContents
  Range("A5").Resize(UBound(ar), 4) = ar
  
End Sub

从从容容

Dim arr()
Dim x, j, k
Sheets("查询").Range("a5:d" & Sheets("查询").Range("a65536").End(3).Row).ClearContents
For x = 1 To Sheets.Count - 1
  Do
  j = j + 1
   If Sheets(x).Cells(j, 2) = Sheets("查询").[b2] Then
   k = k + 1
   ReDim Preserve arr(1 To 4, 1 To k)
   arr(1, k) = Sheets(x).Name
   arr(2, k) = Sheets(x).Cells(j, 1)
   arr(3, k) = Sheets(x).Cells(j, 2)
   arr(4, k) = Sheets(x).Cells(j, 3)
   End If
  Loop Until j = Sheets(x).Range("a65536").End(3).Row
  j = 0
  Next x
  Sheets("查询").Range("a5").Resize(UBound(arr, 2), 4) = Application.Transpose(arr)
End Sub

第14课作业.rar (11.13 KB, 下载次数: 9)

2012-5-10 10:52 上传

点击文件名下载附件

上面不可以插入附件，这里补上。谢谢