[字典与数组二期1班] 第2讲作业上交帖

研究研究 · 发表于 2011-12-25 21:59

本帖最后由研究研究于 2011-12-28 18:03 编辑

关于作业的几点说明：
1.必做一，第一参数为单元格区域的时候，没有限制为一行或一列，可为多行多列；第二参数是以出现的次数进行返回，出现的相同次数的元素是统一返回的。
2.选做一，那个筛选界面是我用来说明返回何种结果的，代码过程不用筛选。
3.选做二，就是不可以随机到相同的行次内容。随机选取的10行，要为原数据中不同的行次。

直接贴代码。

rxj_0414 · 发表于 2011-12-25 23:12

Sub rxj_0414附加题()
Dim D As New Dictionary, sht As Worksheet
Dim arr, arr2(), i As Long, j As Long, x As Integer, cnt As Long
With Sheet10
arr = .Range("A2:S" & .Range("B" & .Rows.Count).End(3).Row)
For i = 1 To UBound(arr)
D(arr(i, 14)) = D.Count
Next i
For x = 0 To D.Count - 1
Erase arr2
cnt = 0
For i = 1 To UBound(arr)
If arr(i, 14) = D.Keys(x) Then
cnt = cnt + 1
ReDim Preserve arr2(1 To UBound(arr, 2), 1 To cnt)
For j = 1 To UBound(arr, 2)
arr2(j, cnt) = arr(i, j)
Next j
End If
Next i
For Each sht In Sheets
If sht.Name = D.Keys(x) Then
sht.Delete
End If
Next sht
Set sht = Sheets.Add()
sht.Name = D.Keys(x)
sht.Rows(1) = .Rows(1).Value
sht.Range("A2").Resize(UBound(arr2, 2), UBound(arr2, 1)) = Application.Transpose(arr2)
Next x
End With
End Sub
Sub rxj_0414选做二()
Dim D As New Dictionary
Dim arr, arr2(), i As Long, j As Integer
arr = Sheet11.Range("A1:G" & Sheet11.Cells(Sheet11.Rows.Count, 1).End(3).Row)
Do
D(1 + Int(Rnd() * UBound(arr))) = ""
Loop Until D.Count = 10
ReDim arr2(1 To D.Count, 1 To UBound(arr, 2))
For i = 1 To D.Count
For j = 1 To UBound(arr, 2)
arr2(i, j) = arr(D.Keys(i - 1), j)
Next j
Next i
Sheets("选做二").Range("A1:G10").ClearContents
Sheets("选做二").Range("A1:G10") = arr2
End Sub
Sub rxj_0414选做一()
Dim D As New Dictionary
Dim arr, i As Long, Str As String
Sheet4.Range("E2:E" & Sheet4.Cells(Sheet4.Rows.Count, 2).End(3).Row).ClearContents
arr = Sheet4.Range("A2:B" & Sheet4.Cells(Sheet4.Rows.Count, 2).End(3).Row).Formula
For i = 1 To UBound(arr)
If D.Exists(arr(i, 1)) Then
D.Item(arr(i, 1)) = D.Item(arr(i, 1)) & "+" & VBA.Mid(arr(i, 2), 2)
Else
D.Item(arr(i, 1)) = VBA.Mid(arr(i, 2), 2)
End If
Next i
If D.Count > 0 Then
Str = D("" & Sheet4.[e1] & "")
End If
If Len(Str) = 0 Then
MsgBox "没这个型号"
Exit Sub
End If
Erase arr
arr = VBA.Split(Str, "+", -1)
Sheet4.[E2].Resize(UBound(arr) + 1) = Application.Transpose(arr)
End Sub
Sub rxj_0414必做二()
Dim D As New Dictionary, arr, i As Long, sht As Worksheet
For Each sht In Sheets
If sht.Tab.Color = Sheet3.Tab.Color And sht.Index <> Sheet3.Index Then
arr = sht.Range("A2:B" & sht.Cells(sht.Rows.Count, 2).End(3).Row)
For i = 1 To UBound(arr)
If D.Exists(arr(i, 1)) Then
D(arr(i, 1)) = D(arr(i, 1)) + Val(arr(i, 2))
Else
D(arr(i, 1)) = Val(arr(i, 2))
End If
Next i
Erase arr
End If
Next sht
Sheet3.Range("A:B").ClearContents
Sheet3.[A1].Resize(D.Count) = Application.Transpose(D.Keys)
Sheet3.[B1].Resize(D.Count) = Application.Transpose(D.Items)
End Sub
Function Jc(all, Optional n As Long = 1)
Dim D As New Dictionary, D2 As New Dictionary
Dim i As Long, a, arr
arr = all
For Each a In arr
D.Item(a) = D.Item(a) + 1
Next a
For i = 0 To D.Count - 1
If D2.Exists(D.Items(i)) Then
D2(D.Items(i)) = D2(D.Items(i)) & "|" & D.Keys(i)
Else
D2(D.Items(i)) = D.Keys(i)
End If
Next i
Jc_2 = D2(n)
End Function
Function Jc_2(all, Optional n As Long = 1)
Dim D As New Dictionary, D1 As New Dictionary
Dim arr, a, i As Long, j As Long, tmp
arr = all
On Error GoTo Err1
For Each a In arr
D(a) = D(a) + 1
Next a
If D.Count <= 1 Then
Jc = "没数据"
Exit Function
End If
For i = 0 To D.Count - 1
If D1.Exists(D.Items(i)) Then
D1(D.Items(i)) = D1(D.Items(i)) & "|" & D.Keys(i)
Else
D1(D.Items(i)) = D.Keys(i)
End If
Next i
Erase arr
arr = D1.Keys
For i = 0 To UBound(arr) - 1
For j = i + 1 To UBound(arr)
If arr(i) < arr(j) Then
tmp = arr(i)
arr(i) = arr(j)
arr(j) = tmp
End If
Next j
Next i
If n - 1 > UBound(arr) Then
Jc = "最少元素排No." & UBound(arr) + 1
Else
Jc = D1(arr(n - 1))
If Jc = "" Then Jc = "空格"
End If
Exit Function
Err1:
Jc = "第一参数应为数组"
End Function

复制代码

csmctjg · 发表于 2011-12-26 09:34

'必做一：
Function Jc(ar, Optional j As Long = 1)
Dim s, arr, i As Long, d As New Dictionary
Application.Volatile
arr = ar
For Each s In arr
d(s) = d(s) + 1
Next s
'If j > d.Count Then Exit Function
For i = 0 To d.Count - 1
If d.Items(i) = Application.Large(d.Items, j) Then
Jc = Jc & d.Keys(i) & "|"
End If
Next i
Jc = Left(Jc, Len(Jc) - 1)
End Function
'必做二：
Sub 必做二()
Dim sht As Worksheet, d As New Dictionary, i&, arr
Application.ScreenUpdating = False
With Sheets("必做二")
For Each sht In Sheets
If sht.Name <> "必做二" Then
If sht.Tab.ColorIndex = .Tab.ColorIndex Then
arr = sht.Range("A2:B" & sht.Range("A" & sht.Rows.Count).End(3).Row)
For i = 1 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) + Val(arr(i, 2))
Next i
Erase arr
End If
End If
Next sht
.Range("A2:B" & .Range("A" & .Rows.Count).Row).ClearContents
.[A1] = "产品型号"
.[B1] = "数量汇总"
.[A2].Resize(d.Count) = Application.Transpose(d.Keys)
.[B2].Resize(d.Count) = Application.Transpose(d.Items)
End With
Application.ScreenUpdating = True
End Sub
'选做一：
Private Sub Worksheet_Change(ByVal Target As Range)
Dim arr, brr(1 To 10000), i&, k&, str$
If Target.Address = "$E$1" Then
Range("E2:E" & Rows.Count).ClearContents
str = Target
arr = Range("A2:B" & Range("A" & Rows.Count).End(3).Row).FormulaR1C1
For i = 1 To UBound(arr)
If arr(i, 1) = str Then
k = k + 1
brr(k) = arr(i, 2)
End If
Next i
For i = 1 To k
[E1].Offset(i, 0) = Replace(brr(i), "=", "'=")
Next i
End If
End Sub
'选做二：
Sub 选做二()
Dim arr, brr(1 To 10, 1 To 7), i&, j As Byte, k As Byte, d As New Dictionary
With Sheets("选做二数据源")
arr = .Range("A1:G" & .Cells(.Rows.Count, 1).Row)
End With
Do
i = Int(Rnd() * 58600 + 1)
d(i) = ""
Loop Until d.Count = 10
For j = 1 To 10
For k = 1 To 7
brr(j, k) = arr(d.Keys(j - 1), k)
Next k
Next j
Sheets("选做二").[A1].Resize(10, 7) = ""
Sheets("选做二").[A1].Resize(10, 7) = brr
End Sub
'附加题：
Sub 附加题()
Dim arr, i&, j&, k&, sh As Worksheet
Application.DisplayAlerts = False
With Sheets("附加题")
arr = .Range("N1:N" & .Range("N" & .Rows.Count).End(3).Row + 1)
For i = 2 To UBound(arr) - 1
j = i
While arr(i, 1) = arr(j, 1)
i = i + 1
Wend
For Each sh In Sheets
If sh.Name = arr(j, 1) Then
k = MsgBox("是否删除" & arr(j, 1) & "工作表？", vbYesNo)
If k = 6 Then sh.Delete
End If
Next sh
Set sh = Sheets.Add
sh.Name = arr(j, 1)
sh.[A1].Resize(1, 19) = .[A1].Resize(1, 19).Value
sh.[A2].Resize(i - j, 19) = .Range("A" & j).Resize(i - j, 19).Value
i = i - 1
Next i
End With
Application.DisplayAlerts = True
End Sub

复制代码

乐满地 · 发表于 2011-12-26 15:55

Function Jc(rg, Optional n As Integer = 1)
Dim arr, arr1()
Dim d As New Dictionary
Dim dc As New Dictionary
Dim x As Long, ma
arr = rg
For x = 1 To UBound(arr) '
d(arr(x, 1)) = d(arr(x, 1)) + 1
Next x
ma = Application.WorksheetFunction.Large(d.Items, n)
For x = 1 To UBound(arr)
If d(arr(x, 1)) = ma And Not dc.Exists(arr(x, 1)) Then
dc.Add (arr(x, 1)), ""
End If
Next
arr1 = dc.Keys
For x = 1 To dc.Count
Jc1 = Jc1 & arr1(x - 1) & "|"
Next
Jc = Left(Jc1, Len(Jc1) - 1)
End Function

复制代码

Sub 必做二()
Dim d As New Dictionary
Dim arr, brr, i As Long
For Each sh In Sheets
If sh.Tab.ColorIndex = Sheets("必做二").Tab.ColorIndex And sh.Name <> "必做二" Then
arr = sh.Range("A2:b" & sh.Range("A" & Rows.Count).End(xlUp).Row)
brr = sh.Range("A1:b1")
For i = 1 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2) * 1
Next
End If
arr = ""
Next
Sheets("必做二").Range("a1：b" & Range("A" & Rows.Count).End(xlUp).Row).ClearContents
Sheets("必做二").[a1:b1] = brr
Sheets("必做二").Range("a2").Resize(d.Count) = Application.Transpose(d.Keys)
Sheets("必做二").Range("b2").Resize(d.Count) = Application.Transpose(d.Items)
End Sub

复制代码

Sub 选做一()
Dim arr, cx As String, x As Long
Dim temp As String, shu As String
Range("e2:e" & Range("e65536").End(3).Row + 1).ClearContents
cx = Range("e1").Value
arr = Range("a2:b" & Range("a65536").End(3).Row).Formula
For x = 1 To UBound(arr)
If arr(x, 1) = cx Then
shu = shu & Mid(arr(x, 2), 2, 99) & "+"
End If
Next
If shu = "" Then
MsgBox "未查到你输入的型号"
Exit Sub
End If
arr1 = VBA.Split(shu, "+")
Range("e2").Resize(UBound(arr1)) = Application.Transpose(arr1)
End Sub

复制代码

Sub 选做二()
Dim irow As Long, k As Long
Dim d As New Dictionary
Dim arr1, arr2, arr(1 To 10, 1 To 7)
irow = Sheets("选做二数据源").Range("a65536").End(3).Row + 1
arr1 = Sheets("选做二数据源").Range("a1:g" & irow - 1)
Application.Volatile
Do
k = Int(Rnd() * irow)
If Not d.Exists(k) Then
d.Add k, ""
End If
Loop Until d.Count = 10
arr2 = Application.Transpose(d.Keys)
For x = 1 To 10
arr(x, 1) = arr1(arr2(x, 1), 1)
arr(x, 2) = arr1(arr2(x, 1), 2)
arr(x, 3) = arr1(arr2(x, 1), 3)
arr(x, 4) = arr1(arr2(x, 1), 4)
arr(x, 5) = arr1(arr2(x, 1), 5)
arr(x, 6) = arr1(arr2(x, 1), 6)
arr(x, 7) = arr1(arr2(x, 1), 7)
Next
Range("A1").Resize(10, 7) = arr
End Sub

复制代码

Sub 附加题()
Dim arr1, arr2, brr, arr(1 To 1000, 1 To 19)
Dim x As Long, m As Long, k As Long, y As Integer
Dim d As New Dictionary, k1 As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
m = Cells(Rows.Count, 2).End(3).Row
arr1 = Range("a2:s" & m)
For x = 1 To m - 1
If Not d.Exists(arr1(x, 14)) Then
d.Add (arr1(x, 14)), ""
End If
Next x
arr2 = Application.Transpose(d.Keys)
brr = Range("a1:s1")
For k = 1 To d.Count
For x = 1 To m - 1
If arr2(k, 1) = arr1(x, 14) Then
k1 = k1 + 1
For y = 1 To 19
arr(k1, y) = arr1(x, y)
Next y
End If
Next x
For Each sh In Sheets
If sh.Name = arr2(k, 1) Then
If MsgBox("工作表“" & arr2(k, 1) & "”已存在，是否删除？", vbQuestion + vbYesNo, "删除提示") = vbYes Then
Sheets(arr2(k, 1)).Delete
MsgBox "删除成功"
Else
MsgBox "你取消了删除"
GoTo 100
End If
End If
Next
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = arr2(k, 1)
100:
Range("a1:s1") = brr
Range("a2").Resize(k1, 19) = arr
Erase arr
k1 = 0
Next k
Sheets("附加题").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

复制代码

sunjing-zxl · 发表于 2011-12-26 18:05

作业2-012-sunjing-zxl.rar (1.4 MB, 下载次数: 32)

我不知道呀 · 发表于 2011-12-26 18:21

Sub 我不知道呀() '必做二代码
On Error Resume Next
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
Dim arr
Dim i As Long
Dim Sht As Worksheet, n As Long, u As Long, Arr1(), p As Long, j As Long
For Each Sht In Worksheets
      If Sht.Name <> "必做二" And Sht.Tab.ColorIndex = 6 Then
         j = Sht.Range("a65536").End(xlUp).Row
      End If
      For p = 1 To j
         n = n + 1
         ReDim Preserve Arr1(1 To 2, 1 To n)
         Arr1(1, n) = Sht.Cells(p, 1)
         Arr1(2, n) = Sht.Cells(p, 2)
      Next
Next
arr = Application.Transpose(Arr1)
For i = 1 To UBound(arr)
      If d.Exists(arr(i, 1)) Then
         d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2) * 1
      Else
         d.Add arr(i, 1), arr(i, 2) * 1
      End If
Next i
s = d.Items
Range("a2:b" & Rows.Count).Clear
Range("a2").Resize(d.Count, 1) = Application.Transpose(d.Keys)
Range("b2").Resize(d.Count, 1) = Application.Transpose(d.Items)
End Sub

windimi007 · 发表于 2011-12-26 19:35

研究学委辛苦了！{:1612:}

【字典2.004】windimi007前来交作业，期待研究学委的点评！{:3112:}

必做一：

Function Jc(rg As Range, Optional k As Long = 1)
Dim d As Object
Dim arr
Dim x, y
Dim i%, j%
Dim sr$
Set d = CreateObject("scripting.dictionary")
arr = rg
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
d(arr(i, j)) = d(arr(i, j)) + 1
Next j
Next i
x = d.keys
y = d.items
For i = 0 To d.Count - 1
If y(i) = k Then sr = sr & x(i) & "|"
Next i
Jc = Left(sr, Len(sr) - 1)
End Function

复制代码

必做二：

Sub aa()
Dim d As Object
Dim sh As Worksheet
Dim arr
Dim i&
Set d = CreateObject("scripting.dictionary")
For Each sh In Worksheets
If sh.Tab.ColorIndex = Sheets("必做二").Tab.ColorIndex And sh.Name <> "必做二" Then
arr = sh.Range("A1").CurrentRegion
For i = 2 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) + Val(arr(i, 2))
Next i
Erase arr
End If
Next sh
Sheets("必做二").[A1:B1] = [{"产品型号","数量"}]
Sheets("必做二").[A2].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
Sheets("必做二").[B2].Resize(d.Count) = WorksheetFunction.Transpose(d.items)
End Sub

复制代码

选做一：

Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object
Dim arr1, arr2
Dim i&
If Target.Address(0, 0) = "E1" Then
Set d = CreateObject("scripting.dictionary")
arr1 = Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
arr2 = Range("B2:B" & Cells(Rows.Count, 2).End(3).Row).Formula
For i = 1 To UBound(arr1)
d(arr1(i, 1)) = d(arr1(i, 1)) & Right(arr2(i, 1), Len(arr2(i, 1)) - 1) & "+"
Next i
x = Split(d([E1].Value), "+")
If Not IsEmpty([E2]) Then Range("E2:E" & Cells(Rows.Count, 5).End(3).Row).ClearContents
Range("E2").Resize(UBound(x)) = WorksheetFunction.Transpose(x)
End If
End Sub

复制代码

选做二：

Sub 按钮3_Click()
Dim d As Object
Dim arr
Dim brr(1 To 10, 1 To 7)
Dim x
Dim i&
Set d = CreateObject("scripting.dictionary")
arr = Sheets("选做二数据源").Range("A1").CurrentRegion
Do
d(Int(Rnd() * UBound(arr) + 1)) = ""
Loop Until d.Count = 10
x = d.keys
For i = 1 To 10
brr(i, 1) = WorksheetFunction.Index(arr, x(i - 1), 1)
brr(i, 2) = WorksheetFunction.Index(arr, x(i - 1), 2)
brr(i, 3) = WorksheetFunction.Index(arr, x(i - 1), 3)
brr(i, 4) = WorksheetFunction.Index(arr, x(i - 1), 4)
brr(i, 5) = WorksheetFunction.Index(arr, x(i - 1), 5)
brr(i, 6) = WorksheetFunction.Index(arr, x(i - 1), 6)
brr(i, 7) = WorksheetFunction.Index(arr, x(i - 1), 7)
Next i
Range("A1").Resize(10, 7) = brr
End Sub

复制代码

附加题：

Sub 矩形1_Click()
Dim d As Object, dic As Object
Dim x
Dim arr
Dim brr()
Dim sh As Worksheet
Dim i&, j&, k&, l&
Dim mg$
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
arr = Range("A1").CurrentRegion
For i = 2 To UBound(arr)
d(arr(i, 14)) = ""
Next i
For Each sh In Worksheets
dic(sh.Name) = ""
Next sh
x = d.keys
For i = 1 To d.Count
If dic.exists(x(i - 1)) Then
mg = MsgBox("工作表已存在，是否删除？", vbYesNo + vbExclamation, "提示")
If mg = vbYes Then
Application.DisplayAlerts = False
Sheets(x(i - 1)).Delete
Application.DisplayAlerts = True
Else
GoTo 7
End If
End If
Sheets.Add(, Sheets(Sheets.Count)).Name = x(i - 1)
For j = 1 To UBound(arr)
If arr(j, 14) = x(i - 1) Then
k = k + 1
ReDim Preserve brr(1 To UBound(arr, 2) - 1, 1 To k)
For l = 1 To UBound(arr, 2) - 1
brr(l, k) = arr(j, l + 1)
Next l
End If
Next j
Range("A1").Resize(, UBound(brr) + 1) = [{"序号","工作单号","受理时间","发货方式","品名","数量","计费重量","到达地","委托人","服务费","保险费","包装费","应收合计","委托单位","客户编号","应收到付","应收代收","重要提示","收货人"}]
Range("B2").Resize(UBound(brr, 2), UBound(brr)) = WorksheetFunction.Transpose(brr)
Erase brr
k = 0
7:
Next i
Application.ScreenUpdating = True
End Sub

复制代码

liuts · 发表于 2011-12-27 08:05

本帖最后由 liuts 于 2011-12-28 08:06 编辑

作业2-liuts.rar (1.24 MB, 下载次数: 103)

hxigang · 发表于 2011-12-27 09:16

'必做二
Sub hxigang()
Dim Arr6, Arr8, Arr9: Dim i As Single
Sheet3.[a1].CurrentRegion.Delete
Set dit1 = CreateObject("scripting.dictionary")
Arr6 = Sheet6.UsedRange
Arr8 = Sheet8.UsedRange
Arr9 = Sheet9.Range("a1:b" & Sheet9.[b65536].End(xlUp).Row)
dit1("产品型号") = "数量"
For i = 2 To UBound(Arr6)
dit1(Arr6(i, 1)) = dit1(Arr6(i, 1)) + CInt(Arr6(i, 2))
Next i
For i = 2 To UBound(Arr6)
dit1(Arr8(i, 1)) = dit1(Arr8(i, 1)) + CInt(Arr8(i, 2))
Next i
For i = 2 To UBound(Arr6)
dit1(Arr9(i, 1)) = dit1(Arr9(i, 1)) + CInt(Arr9(i, 2))
Next i
Sheet3.Range("A1").Resize(dit1.Count, 1) = Application.Transpose(dit1.Keys)
Sheet3.Range("B1").Resize(dit1.Count, 1) = Application.Transpose(dit1.Items)
Set dit1 = Nothing
Erase Arr6: Erase Arr8: Erase Arr9
End Sub

Benol · 发表于 2011-12-27 09:53

Function 必做1(rng As Variant, Optional rnk& = 1) As String
Dim rng_arr, v, item_arr, key_arr, tmp
Dim dic As New Dictionary, dic_cntrnk As New Dictionary
'=========获取源数据==========
If Not IsArray(rng) Then
rng_arr = Split(rng)
Else
rng_arr = rng
End If
'=========分类计数==========
For Each v In rng_arr
If v <> "" Then
dic(v) = dic(v) + 1
End If
Next
item_arr = dic.Items
key_arr = dic.Keys
Set dic = Nothing
'=========根据计数大小理出结果==========
For i = 0 To UBound(key_arr)
dic_cntrnk(item_arr(i)) = dic_cntrnk(item_arr(i)) & "|" & key_arr(i)
Next
tmp = dic_cntrnk(Application.Large(dic_cntrnk.Keys, rnk))
必做1 = Right(tmp, Len(tmp) - 1)
End Function

复制代码

Sub 必做2()
Dim sht As Worksheet
Dim tabcolor, arr, dic As New Dictionary
tabcolor = Sheets("必做二").Tab.ColorIndex '拾色
For Each sht In Sheets
If sht.Name <> "必做二" Then
If sht.Tab.ColorIndex = tabcolor Then '对色
arr = sht.Range("A2:B" & sht.[a65536].End(3).Row)
For i = 1 To UBound(arr)
dic(arr(i, 1)) = dic(arr(i, 1)) + arr(i, 2)
Next
End If
End If
Next
Sheets("必做二").Select
Range("a:b").ClearContents: [A1] = "产品型号": [B1] = "数量"
Range("A2").Resize(dic.Count) = Application.Transpose(dic.Keys)
Range("B2").Resize(dic.Count) = Application.Transpose(dic.Items)
End Sub

复制代码

Private Sub Worksheet_Change(ByVal Target As Range)
Dim src, v_target, dest(1 To 10000, 1 To 1), dic As New Dictionary
If Target.Address = "$E$1" Then
v_target = Target
src = Range("A2:B" & [a65536].End(3).Row).Formula
For i = 1 To UBound(src)
If src(i, 1) = v_target Then
k = k + 1
dest(k, 1) = src(i, 2)
End If
Next
Range("E2:E10001") = dest
End If
End Sub

复制代码

Sub 选做2()
Dim src, dest&(), end_row&, end_col&, i&, j%, RndIndex&, tmp&, row_index&()
src = Sheets("选做二数据源").UsedRange
end_row = UBound(src)
end_col = UBound(src, 2)
If end_row > 10 Then
'========制作乱序行号=========
ReDim row_index(1 To end_row)
For i = 1 To end_row
row_index(i) = i
Next
For i = 1 To end_row
RndIndex = Int(Rnd() * end_row) + 1
tmp = row_index(i)
row_index(i) = row_index(RndIndex)
row_index(RndIndex) = tmp
Next
'========获取数据=========
ReDim dest(1 To 10, 1 To end_col)
For j = 1 To 10
For i = 1 To end_col
dest(j, i) = src(row_index(j), i)
Next
Next
'========写入数据=========
Sheets("选做二").Range("A1").Resize(10, end_col) = dest
Else '数据源不大于10行则直接传送所有数据
With Sheets("选做二")
.UsedRange.ClearContents
.Range("A1").Resize(end_row, end_col) = src
End With
End If
End Sub

复制代码

		自动登录	找回密码
密码			注册

[习题] [字典与数组二期1班] 第2讲作业上交帖

评分

相关帖子

点评

点评

点评

评分