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

yijundanny

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

qushui

a组学委:qushui

1. Sub 筛选()
   
2.     Dim arr, brr(), st As Worksheet
   
3.     Dim i&, j&, k&, pm$
   
4.     pm = Sheets("查询").[b2]
   
5.     For Each st In Sheets
   
6.         If st.Name Like "[ABC]" & "店" Then
   
7.             arr = st.Range("a1").CurrentRegion.Value
   
8.             For i = 2 To UBound(arr)
   
9.                 If arr(i, 2) = pm Then
   
10.                     k = k + 1
    
11.                     ReDim Preserve brr(1 To 4, 1 To k)
    
12.                     brr(1, k) = st.Name
    
13.                     brr(2, k) = arr(i, 1)
    
14.                     brr(3, k) = pm
    
15.                     brr(4, k) = arr(i, 3)
    
16.                 End If
    
17.             Next i
    
18.             Erase arr
    
19.         End If
    
20.     Next st
    
21.     With Sheets("查询")
    
22.         .Range("a5:d" & .[a65536].End(3).Row).ClearContents
    
23.         .[a5].Resize(k, 4) = Application.Transpose(brr)
    
24.     End With
    
25. End Sub
    

复制代码

vbamaster

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

2012-5-14 21:53 上传

点击文件名下载附件
D05:vbamaster

无聊的疯子

A03:无聊的疯子

1. 
   
2. Sub 筛选()
   
3. Dim Sh As Worksheet, Arr, Brr(1 To 100, 1 To 4)
   
4. Dim X As Integer, H As Integer, S As String
   
5.   S = Sheets("查询").Range("B2").Value
   
6.   For Each Sh In Worksheets
   
7.     If Sh.Name <> "查询" Then
   
8.       Arr = Sh.UsedRange
   
9.       For X = 2 To UBound(Arr)
   
10.         If Arr(X, 2) = S Then
    
11.           H = H + 1
    
12.           Brr(H, 1) = Sh.Name
    
13.           Brr(H, 2) = Arr(X, 1)
    
14.           Brr(H, 3) = Arr(X, 2)
    
15.           Brr(H, 4) = Arr(X, 3)
    
16.         End If
    
17.       Next
    
18.     End If
    
19.   Next
    
20.   With Sheets("查询").Range("A5:D100")
    
21.     .ClearContents
    
22.     .Value = Brr
    
23.   End With
    
24. End Sub
    
25. 
    

复制代码

sliang28

C09:sliang28

1. Sub 筛选()
   
2. Dim sht As Worksheet
   
3. Dim data() As Variant
   
4. Dim n, k, i As Long
   
5. Dim last_n As Long
   
6. Dim list(1 To 99999, 1 To 4) As Variant
   
7. Dim pro As String
   
8. 
   
9. Worksheets("查询").[A5].Resize(1000, 4).ClearContents
   
10. 
    
11. pro = Worksheets("查询").[B2]
    
12. 
    
13. last_n = Worksheets.Count
    
14. 
    
15. ReDim data(1 To last_n) As Variant
    
16. 
    
17. k = 0
    
18. 
    
19. For Each sht In Worksheets
    
20.     If sht.Name <> "查询" Then
    
21.         n = sht.[A1].End(xlDown).Row
    
22.         data(sht.Index) = sht.Range("A2:C" & n)
    
23.         For i = 1 To UBound(data(sht.Index))
    
24.             If data(sht.Index)(i, 2) = pro Then
    
25.                 k = k + 1
    
26.                 list(k, 1) = sht.Name
    
27.                 list(k, 2) = data(sht.Index)(i, 1)
    
28.                 list(k, 3) = pro
    
29.                 list(k, 4) = data(sht.Index)(i, 3)
    
30.             End If
    
31.         Next
    
32.     End If
    
33. Next
    
34. 
    
35. Worksheets("查询").[A5].Resize(k, 4) = list
    
36. 
    
37. MsgBox pro & "商品查询结束。"
    
38. 
    
39. 
    
40. End Sub
    

复制代码

zjyxp

D09 zjyxp
不会做，重在参与学习，恳请校长指导！

1. Sub 筛选()
   
2.     Dim arr, arr1(1 To 100, 1 To 3)
   
3.     Dim x As Integer, k As Integer
   
4.      Sheets("A店").Range("a1:c8").Copy Sheets("查询").Range("m1")
   
5.      Sheets("B店").Range("a2:c15").Copy Sheets("查询").Range("m9")
   
6.      Sheets("C店").Range("a2:c15").Copy Sheets("查询").Range("m23")
   
7.         arr = Range("m1:o36")
   
8.            For x = 2 To 36
   
9.            If arr(x, 2) = Range("b2").Value Then
   
10.                 k = k + 1
    
11.                 arr1(k, 1) = arr(x, 1)
    
12.                 arr1(k, 2) = arr(x, 2)
    
13.                 arr1(k, 3) = arr(x, 3)
    
14.                  End If
    
15.             Next
    
16.         Range("b5").Resize(k, 3) = arr1
    
17.         Range("m1:o36").ClearContents
    
18. End Sub
    

复制代码

shengxudong

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

2012-5-15 12:14 上传

点击文件名下载附件 Option Explicit
Sub 筛选()
Dim Sdsheetsname As String
Dim sheetsx As Integer
Dim sp As String
Dim dx As String '店名首字符
Dim Plist As Integer '数组行数
Dim arrsp() As String ' 数组
Dim rowsx As Integer  '各店数据行数
Dim sxrows As Integer  '筛选表数据行数
Sheets("查询").Select
[a5:d100] = ""
sp = Cells(2, 2).Value
For sheetsx = 1 To Sheets.Count
    Sdsheetsname = Sheets(sheetsx).Name
    dx = Left(Sdsheetsname, 1)
    If dx Like "*[A-Z]*" Then
        Sheets(Sdsheetsname).Select
        rowsx = 2
        Do While Cells(rowsx, 2) <> ""
            If Cells(rowsx, 2).Value = sp Then
                If Plist = 0 Then
                    ReDim Preserve arrsp(3, Plist)
                    arrsp(0, Plist) = Sdsheetsname
                    arrsp(1, Plist) = Cells(rowsx, 1)
                    arrsp(2, Plist) = Cells(rowsx, 2)
                    arrsp(3, Plist) = Cells(rowsx, 3)
                    Plist = Plist + 1
                Else
                    ReDim Preserve arrsp(3, Plist)
                    arrsp(0, Plist) = Sdsheetsname
                    arrsp(1, Plist) = Cells(rowsx, 1)
                    arrsp(2, Plist) = Cells(rowsx, 2)
                    arrsp(3, Plist) = Cells(rowsx, 3)
                    Plist = Plist + 1
                End If
            End If
            rowsx = rowsx + 1
        Loop
        rowsx = 2
    End If
Next sheetsx
Plist = Plist - 1
Sheets("查询").Select
For sxrows = 0 To Plist
    Cells(sxrows + 5, 1).Value = arrsp(0, sxrows)
    Cells(sxrows + 5, 2).Value = arrsp(1, sxrows)
    Cells(sxrows + 5, 3).Value = arrsp(2, sxrows)
    Cells(sxrows + 5, 4).Value = arrsp(3, sxrows)
Next sxrows
End Sub

liuho1

Sub 筛选()
  Dim x As Long, y As Long, a As Long, b As Long, c As Long, d As Long, e As Long, f As Long, g As Long, h As Long, i As String
  Dim arr
  Dim arr1
  Dim arr2
  Application.ScreenUpdating = False
  f = Sheets(1).Range("a65536").End(xlUp).Row + Sheets(2).Range("a65536").End(xlUp).Row + Sheets(3).Range("a65536").End(xlUp).Row - 3
  ReDim arr(1 To f, 1 To 4)
  i = Sheets("查询").Range("B2")
a = Sheets.Count
  For b = 1 To a - 1
  Sheets(b).Select
  c = Range("a65536").End(xlUp).Row
   arr1 = Range("a2:c" & c)
  For x = 1 To c - 1
  d = d + 1
  arr(d, 1) = Sheets(b).Name
    For y = 1 To 3
       arr(d, y + 1) = arr1(x, y)
    Next y
  Next x
  Next b
  ReDim arr2(1 To UBound(arr), 1 To 4)
For e = 1 To UBound(arr)
If arr(e, 3) = i Then
g = g + 1
For h = 1 To 4
arr2(g, h) = arr(e, h)
Next
End If
Next
Sheets("查询").Range("A5").Resize(UBound(arr2), 4) = arr2
Sheets("查询").Select
  Application.ScreenUpdating = True
End Sub
14课作业-B06-liuho1.zip (13.48 KB, 下载次数: 5)

2012-5-15 13:28 上传

点击文件名下载附件

ybchxj2010

1. 
   

复制代码

Sub 筛选()
Dim arr, arr1()
Dim x%, y%, r%
Dim str$, nstr$
Dim sh As Worksheet
str = Sheets("查询").Range("B2").Value
For x = 1 To 3
    Set sh = Sheets(x)
    nstr = sh.Name
    arr = sh.Range("a2:c" & sh.[a65536].End(xlUp).Row)
    For y = 1 To UBound(arr)
      If arr(y, 2) = str Then
        r = r + 1
        ReDim Preserve arr1(1 To 4, 1 To r)
        arr1(1, r) = nstr
        arr1(2, r) = arr(y, 1)
        arr1(3, r) = arr(y, 2)
        arr1(4, r) = arr(y, 3)
      End If
  Next: Next
  
  Range("a5:d" & [a65536].End(3).Row).ClearContents
  Range("a5").Resize(r, 4) = Application.Transpose(arr1)
End Sub

libenwen2011

libenwen2011 发表于 2012-5-10 15:17
16组：libenwen2011   (UID: 514207)

Sub 筛选()

cO(∩_∩)O谢谢老师。