【字典201201班】B组（B01—B22）第3讲作业上交贴

银鱼 · 发表于 2012-6-17 10:40

题1

Dim i, j, k As Integer
Dim arr, arr1(), arr2
Dim d
Set d = CreateObject("scripting.dictionary")
With Sheets("题1")
arr = .[a1].CurrentRegion
ReDim arr1(1 To UBound(arr), 1 To 3)
arr2 = .[d1].CurrentRegion
For i = 2 To UBound(arr2)
j = j + 1
d(arr2(i, 2)) = j
arr1(i - 1, 1) = j
arr1(i - 1, 2) = arr2(i, 2)
Next
For k = 2 To UBound(arr)
If d.exists(arr(k, 1)) Then
arr1(d(arr(k, 1)), 3) = arr1(d(arr(k, 1)), 3) + arr(k, 2)
Else
j = j + 1
d(arr(k, 1)) = j
arr1(j, 1) = j
arr1(j, 2) = arr(k, 1)
arr1(j, 3) = arr(k, 2)
End If
Next
.[d2].Resize(UBound(arr1), 3) = arr1
.Range(.Cells(UBound(arr2) + 1, 4), .Cells(.[e65536].End(xlUp).Row, 5)).Font.Bold = True
End With

复制代码

题2

Dim i As Integer
Dim arr, arr1, arr2
Dim d
Set d = CreateObject("scripting.dictionary")
With Sheets("题2")
arr = .Range("a1:b" & .[b65536].End(xlUp).Row)
For i = 2 To UBound(arr)
If arr(i, 1) = "" Then arr(i, 1) = arr(i - 1, 1)
If d.exists(arr(i, 1)) And arr(i, 2) >= 100 And arr(i, 2) <= 400 Then
d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
ElseIf arr(i, 2) >= 100 And arr(i, 2) <= 400 Then
d(arr(i, 1)) = arr(i, 2)
End If
Next
arr1 = Application.Transpose(d.keys)
arr2 = Application.Transpose(d.items)
.[e2].Resize(UBound(arr1)) = arr1
.[f2].Resize(UBound(arr2)) = arr2
End With

复制代码

ゅ閪閪ヘ · 发表于 2012-6-17 11:16

第3讲-B12-ゅ閪閪ヘ.zip (22.18 KB, 下载次数: 7)

雨后彩霞 · 发表于 2012-6-19 09:47

Sub 第一题()
Dim arr, hx As Long, arr1(1 To 999, 1 To 3)
Dim y As Byte
Dim d As New Dictionary
With Range("f2:f9,d10:f100")
      .Font.Bold = False '区域中的字体设为加粗
      .ClearContents '数据表上单元格区域中的公式，但保留其格式设置
End With
hx = Range("e65536").End(xlUp).Row

arr = Range("e2:e" & hx)
For y = 1 To UBound(arr)
      d(arr(y, 1)) = y
      arr1(y, 1) = y
      arr1(y, 2) = arr(y, 1)
Next y
hx = Range("a65536").End(xlUp).Row

arr = Range("a2:b" & hx)
For hx = 1 To UBound(arr)
      If d.Exists(arr(hx, 1)) Then
         arr1(d(arr(hx, 1)), 3) = arr1(d(arr(hx, 1)), 3) + arr(hx, 2)
      Else
         d(arr(hx, 1)) = d.Count + 1
         arr1(d(arr(hx, 1)), 1) = d.Count
         arr1(d(arr(hx, 1)), 2) = arr(hx, 1)
         arr1(d(arr(hx, 1)), 3) = arr(hx, 2)
      End If
Next
Range("d2").Resize(d.Count, 3) = arr1
Range("d" & y + 1).Resize(d.Count - y + 1, 2).Font.Bold = True
End Sub
Sub 第二题()
Dim arr, arr1(1 To 999, 1 To 2)
Dim x As Long
Dim y As String
Dim y1 As Long
Dim y2 As Long
Dim d As New Dictionary
With Sheets("题2")
      y1 = .Range("d2")
      y2 = .Range("c2")
      .Range("e2:f100").ClearContents
      x = .Range("b65536").End(xlUp).Row
      arr = .Range("a2:b" & x)
      For x = 1 To UBound(arr)
         y = IIf(Len(arr(x, 1)) = 0, y, arr(x, 1))
         If arr(x, 2) >= y2 And arr(x, 2) <= y1 Then
            If d.Exists(y) Then
                  arr1(d(y), 2) = arr1(d(y), 2) + arr(x, 2)
            Else
                  d(y) = d.Count + 1
                  arr1(d(y), 1) = y
                  arr1(d(y), 2) = arr(x, 2)
            End If
         End If
      Next
      .Range("e2").Resize(d.Count, 2) = arr1
End With
End Sub

YESS95 · 发表于 2012-6-20 11:44

Sub test()
Dim d
Dim i As Integer
Dim c As Integer
Set d = CreateObject("scripting.dictionary")
For i = 2 To 9
d(Cells(i, "E").Value) = d.Count + 1
Next i
c = d.Count + 1
For i = 2 To Cells(Rows.Count, "a").End(xlUp).Row
If d.Exists(Cells(i, 1).Value) = False Then
d(Cells(i, 1).Value) = d.Count + 1
Cells(d(Cells(i, 1).Value) + 1, "d").Value = d(Cells(i, 1).Value)
Cells(d(Cells(i, 1).Value) + 1, "E").Value = Cells(i, 1).Value
End If
Cells(d(Cells(i, 1).Value) + 1, "F").Value = Cells(d(Cells(i, 1).Value) + 1, "F").Value + Cells(i, 2).Value
Next i
Range(Cells(c + 1, "d"), Cells(Rows.Count, "f").End(xlUp)).Font.Bold = True
Set d = Nothing
End Sub

复制代码

Sub test1()
Dim d
Dim i As Long
Dim arr()
Set d = CreateObject("scripting.dictionary")
arr = Range([a2], Cells(Rows.Count, "b").End(xlUp)).Value
For i = 1 To UBound(arr, 1)
If arr(i, 1) = "" Then
arr(i, 1) = arr(i - 1, 1)
End If
d(arr(i, 1)) = arr(i, 2)
If d(arr(i, 1)) >= 100 And d(arr(i, 1)) <= 400 Then
d(arr(i, 1)) = arr(i, 2) + d(arr(i, 1))
End If
Next i
Range("e2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Keys)
Range("f2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Items)
Set d = Nothing
End Sub

复制代码

我不知道呀 · 发表于 2012-6-20 12:43

我不知道呀发表于 2012-6-15 20:38
第一题代码:
Sub aa2()
Dim d As New Dictionary

那天附件上传不了，所以就直接贴代码了

7777 · 发表于 2012-6-20 17:26

本帖最后由 7777 于 2012-6-20 17:45 编辑

B15:7777  只做出了第一题
Sub 第一题作业()
Dim D1 As New Dictionary
Dim ARR
Dim I As Long
ReDim ARR(1 To 8, 1 To 2)
Range("d10:f65535").ClearContents
Range("f2:f9").ClearContents
ARR = Range("D2：E9")
  For I = 1 To 8
  D1(ARR(I, 2)) = ARR(I, 1)
  Next
For I = 2 To Range("A65535").End(xlUp).Row
If D1.Exists(Cells(I, 1).Value) = False Then
   D1(Cells(I, 1).Value) = D1.Count + 1
   Cells(D1.Count + 1, "D") = D1.Count
   Cells(D1.Count + 1, "e") = Cells(I, 1)
   Cells(D1.Count + 1, "f") = Cells(I, 2)
   Range("d10:f" & D1.Count + 2).Font.Bold = True
Else
   Cells(D1(Cells(I, 1).Value) + 1, "F") = Cells(D1(Cells(I, 1).Value) + 1, "F") + Cells(I, 2)
End If
  Next
End Sub

从从容容 · 发表于 2012-6-20 17:56

从从容容发表于 2012-6-16 09:29

免费的，不用白不用。

liuxingyi88 · 发表于 2012-6-20 18:08

真的太忙，没写作业请谅解！！！

liuguansky · 发表于 2012-6-20 19:09

参考代码：

Option Explicit
Sub Q1()
Dim D As New Dictionary, Arr, i&, Ar(1 To 60000, 1 To 3), K&, NAdd&
Arr = Range([e2], [e2].End(4)).Value
For i = 1 To UBound(Arr)
D.Add Arr(i, 1), i
Ar(i, 1) = i: Ar(i, 2) = Arr(i, 1)
Next i
K = i - 1: NAdd = K
Arr = Range([a2], [b2].End(4)).Value
For i = 1 To UBound(Arr)
If D.Exists(Arr(i, 1)) Then
Ar(D(Arr(i, 1)), 3) = Ar(D(Arr(i, 1)), 3) + Arr(i, 2)
Else
K = K + 1
D.Add Arr(i, 1), K
Ar(K, 1) = K: Ar(K, 2) = Arr(i, 1): Ar(K, 3) = Arr(i, 2)
End If
Next i
Range("d2:f" & Rows.Count).ClearContents
[d2].Resize(K, 3) = Ar
If K > NAdd Then [d2].Offset(NAdd).Resize(K - NAdd, 2).Font.Bold = True
Set D = Nothing
End Sub

复制代码

Option Explicit
Sub Q2()
Dim D As New Dictionary, Arr, K&
Dim MaxN&, MinN&, i&, Ar(1 To 60000, 1 To 2)
MinN = [c2]: MaxN = [d2]
Arr = Range([a2], [b2].End(4)).Value
For i = 1 To UBound(Arr)
If Len(Arr(i, 1)) = 0 Then
Arr(i, 1) = Arr(i - 1, 1)
End If
If Arr(i, 2) >= MinN And Arr(i, 2) <= MaxN Then
If D.Exists(Arr(i, 1)) Then
Ar(D(Arr(i, 1)), 2) = Ar(D(Arr(i, 1)), 2) + Arr(i, 2)
Else
K = K + 1: D.Add Arr(i, 1), K
Ar(K, 1) = Arr(i, 1): Ar(K, 2) = Arr(i, 2)
End If
End If
Next i
Range("e2:f" & Rows.Count).ClearContents
[e2].Resize(K, 2) = Ar
Set D = Nothing
End Sub

复制代码

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

[习题] 【字典201201班】B组（B01—B22）第3讲作业上交贴

点评

评分

点评

评分

点评

评分

点评

评分