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))., 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
Sub 筛选()
Range("a5:d1000").Clear
Dim sheetcount As Integer, x As Integer, arr(1 To 10000, 1 To 4)
Dim k As Integer
For sheetcount = 1 To 3
With Sheets(sheetcount)
For x = 2 To .Range("a65536").End(xlUp).Row
If .Cells(x, "b") = Range("b2") Then
k = k + 1
arr(k, 1) = .Name
arr(k, 2) = .Cells(x, "a")
arr(k, 3) = .Cells(x, "b")
arr(k, 4) = .Cells(x, "c")
End If
Next x
End With
Next sheetcount
Range("a5").Resize(k, 4) = arr
End Sub
H19:chenzhi_juan
来交下数组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(店)., 品名) '统计单内符合条件的品名数
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 于 2012-5-11 13:10 编辑
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
我的作业如下，请批改。谢谢！
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
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
g17:szczm121
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
辛苦校长了～～～～～～～～～～
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
校长辛苦了！