统计VBA学习小组正式组的积分帖之作业上交贴（第17周）
本帖最后由 兰色幻想 于 2012-5-15 19:39 编辑说明:
统计帖每个学员只能跟帖回复一次，也就是在原来回复楼层的基础上点编缉，不要一个链接一层楼，否则不计算积分。
各小组学员上交作业时，一定要点击“我要参加”，并注明自己的新组编号和论坛ID，如果点击过“我要参加”但没有跟帖提交作业的，扣该学员5积分；如果跟帖提交了作业，但没有点“我要参加”的，不给予评分。
请各学员看清上面的说明，免得被扣了分分！
本帖为仅楼主可见帖，直接回复即可！
作业链接：
http://www.excelpx.com/thread-241980-1-1.html
C12:hrpotterSub 筛选()
Dim ar, br(1 To 10000, 1 To 4)
Dim i As Integer, j As Integer, k As Integer
Dim s As String
s = Range("b2")
For i = 1 To 3
ar = Sheets(i).Range("a1").CurrentRegion
For j = 2 To UBound(ar)
If ar(j, 2) = s Then
k = k + 1
br(k, 1) = Sheets(i).Name
br(k, 2) = ar(j, 1)
br(k, 3) = ar(j, 2)
br(k, 4) = ar(j, 3)
End If
Next
Next
Range("a5:d65536").Clear
If k > 0 Then Range("a5").Resize(k, 4) = br
End Sub 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
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("查询"). 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 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
本帖最后由 我不知道呀 于 2012-5-10 07:11 编辑
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
E学委:sunjing-zxl 上交第14课作业
Sub 筛选()
Dim arr(), arr1
Dim i As Long, j As Long, k As Long
Dim n As Long, m As Long
Dim str As String
For i = 1 To Sheets.Count
If Sheets(i).Name Like "*店" Then
n = n + 1
ReDim Preserve arr(1 To n)
arr(n) = Sheets(i).Range("A2:C" & Sheets(i)..End(xlUp).Row)
arr(n) = Array(arr(n), Sheets(i).Name)
m = m + UBound(arr(n)(0))
End If
Next i
str = Cells(2, 2)
ReDim arr1(1 To m, 1 To 4)
m = 0
For i = 1 To n
For j = 1 To UBound(arr(i)(0))
If arr(i)(0)(j, 2) = str Then
m = m + 1
arr1(m, 1) = arr(i)(1)
For k = 1 To 3
arr1(m, k + 1) = arr(i)(0)(j, k)
Next k
End If
Next j
Next i
Range("A5:D" & .End(xlUp).Row + 1).ClearContents
Range("A5").Resize(UBound(arr1), 4) = arr1
End Sub
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("查询"). 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
上面不可以插入附件，这里补上。谢谢