ExcelVBA_字典套字典实例集锦.zip_ExcelVBA_VBA字典_excelvba实例_vbaexcel_字

共1个文件

doc：1个

版权申诉

excel_vba

字典

60 浏览量 2022-09-24 10:18:02 上传评论收藏 30KB ZIP 举报

资源详情

资源评论

资源推荐

收起资源包目录

Excel VBA_字典套字典实例集锦.zip （1个子文件）

Excel VBA_字典套字典实例集锦.doc 189KB

1，特殊条件编号

‘2012-9-3

‘http://club.excelhome.net/forum.php?mod=viewthread&tid=914702&page=1#pid6271907

Sub lqxs()

Dim Arr, i&, j&, jj&, n&, aa, bb, y, x$

Dim d As New Dictionary, k, t, d1 As New Dictionary, t1

Sheet1.Activate

[e31:e5000].ClearContents

Arr = [a1].CurrentRegion

For i = 31 To UBound(Arr)

x = Arr(i, 4)

y = Arr(i, 1) & "|" & Arr(i, 3)

d(x) = d(x) & i & ","

If d1.Exists(x) = False Then Set d1(x) = New Dictionary

d1(x)(y) = d1(x)(y) & i & ","

k = d.keys

t = d.items

For i = 0 To UBound(k)

t(i) = Left(t(i), Len(t(i)) - 1)

n = 0

If InStr(t(i), ",") Then

aa = Split(t(i), ",")

For j = 0 To UBound(aa)

y = Arr(aa(j), 1) & "|" & Arr(aa(j), 3)

n = n + 1

t1 = d1(k(i))(y)

t1 = Left(t1, Len(t1) - 1)

If InStr(t1, ",") Then

bb = Split(t1, ",")

For jj = 0 To UBound(bb)

Cells(bb(jj), 5) = n

j = j + UBound(bb)

Else

Cells(t1, 5) = n

End If

End Sub

2，列表框 3 级数据有效性

‘2012-9-4

‘http://club.excelhome.net/thread-716135-1-1.html

Dim d1 As New Dictionary

Dim d2 As New Dictionary

Private Sub ComboBox1_Click()

ComboBox2.Clear

ComboBox3.Clear

ComboBox2.List = d1(ComboBox1.Text).Items

End Sub

Private Sub ComboBox2_Click()

ComboBox3 = ""

ComboBox3.List = d2(ComboBox1.Text & ComboBox2.Text).Items

End Sub

Private Sub UserForm_Initialize()

arr = Sheet1.Range("a3:f" & Sheet1.[a65536].End(3).Row)

For i = 1 To UBound(arr)

a = arr(i, 1) & "": b = arr(i, 3) & "": c = arr(i, 6) & ""

x = arr(i, 1) & arr(i, 3)

If d1.Exists(a) = False Then Set d1(a) = New Dictionary

d1(a)(b) = b

If d2.Exists(x) = False Then Set d2(x) = New Dictionary

d2(x)(c) = c

ComboBox1.List = d1.Keys

End Sub

3，填表

‘2012-9-19

‘http://club.excelhome.net/thread-922624-1-1.html

Dim d As New Dictionary

Dim d1 As New Dictionary

Sub 填充()

Dim xm, rkb, rkkm, rlkm, rlxm, r, sckm, km, s

Sheet2.Activate

[b:c].ClearContents

rkb = Sheets("任课表").Range("b2:bi16")

xm = Sheets("绩效名单").Range("a2:a241")

rkkm = Sheets("任课表").Range("a2:a16")

For i = 1 To UBound(rkb)

For j = 1 To UBound(rkb, 2)

If d.exists(rkb(i, j)) = False Then Set d(rkb(i, j)) = New Dictionary

d(rkb(i, j))(rkkm(i, 1)) = rkkm(i, 1)

Next j

Next i

k = d.Keys

k1 = d(k(0)).items

For x = 1 To UBound(xm)

If d.exists(xm(x, 1)) Then

s = d(xm(x, 1)).items

If IsArray(s) Then

Cells(x + 1, 2).Resize(1, UBound(s) + 1) = s

Else

Cells(x + 1, 2) = s

End If

Set d = Nothing

End Sub

4，2 级字典嵌套

‘2013-2-21

‘http://club.excelhome.net/thread-984445-1-1.html

Sub lqxs()

Dim Arr, i&, x, y

Dim d, k, t

Set d = CreateObject("Scripting.Dictionary")

Arr = [a1].CurrentRegion

For i = 2 To UBound(Arr)

x = Arr(i, 1): y = Arr(i, 2)

If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")

d(x)(y) = d(x)(y) + 1

k = d.keys

t = d.items:

For i = 2 To UBound(Arr)

If d.exists(Arr(i, 1)) Then Cells(i, 3) = d(Arr(i, 1)).Count

End Sub

‘2013-1-22

‘http://club.excelhome.net/thread-974297-1-1.html

Sub lqxs()

Dim Arr, i&, j&, n&, tt

Dim d, k, t, d1, x, y, k1

Set d = CreateObject("Scripting.Dictionary")

Set d1 = CreateObject("Scripting.Dictionary")

Sheet2.Activate

Arr = Sheet1.[a1].CurrentRegion

For i = 2 To UBound(Arr)

x = Arr(i, 1)

y = Left(Arr(i, 3), 1)

d(x) = d(x) + 1

If d1.Exists(x) = False Then Set d1(x) = CreateObject("Scripting.Dictionary")

d1(x)(y) = d1(x)(y) + 1

k = d1.keys

t = d1.items: n = 4: tt = 0

For i = 0 To UBound(k)

Cells(n, 1) = "小计"

Cells(n, 2) = k(i)

Cells(n, 3) = t(i).Count

tt = tt + t(i).Count

k1 = t(i).keys

For j = 0 To UBound(k1)

n = n + 1

Cells(n, 2) = k(i)

Cells(n, 3) = k1(j)

Cells(n, 4) = d1(k(i))(k1(j))

n = n + 1

Cells(3, 3) = tt

End Sub

5，3 级字典嵌套

‘2012-1-23

‘http://club.excelhome.net/forum.php?mod=viewthread&tid=974963&page=2#pid6676611

Sub lqxs()

Dim Arr, i&, Arr1, x$, n&, y&, Brr, r%, Brr1(), r2%, Brr2()

Dim d, k, t, d1, k1, t1, k2, kk, a, b, c, cp$

Set d = CreateObject("Scripting.Dictionary")

Set d1 = CreateObject("Scripting.Dictionary")

Sheet3.Activate

[a2:d50000].Clear

Arr1 = Sheet1.[a1].CurrentRegion

Arr = Sheet2.[a1].CurrentRegion

For i = 2 To UBound(Arr)

a = Arr(i, 4): b = Arr(i, 3)

d(b) = a

d.RemoveAll

For i = 2 To UBound(Arr1)

a = Arr1(i, 4): c = Arr1(i, 7)

b = Split(Arr1(i, 3), "]")(1)

cp = a & "," & b

If a <> "" Then

If d.Exists(a) = False Then Set d(a) = CreateObject("Scripting.Dictionary")

d(a)(b) = b

If d1.Exists(cp) = False Then

Set d1(cp) = CreateObject("Scripting.Dictionary")

End If

d1(cp)(c) = d1(cp)(c) + 1

End If

k = d.keys: k1 = d1.keys

t = d.items: t1 = d1.items: n = 2

For i = 0 To UBound(k)

k2 = t(i).keys

Cells(n, 1) = k(i)

For j = 0 To UBound(k2)

Cells(n, 2) = k2(j)

x = k(i) & "," & k2(j)

kk = d1(x).keys

For y = 0 To UBound(kk)

If d1(x)(kk(y)) <> 0 Then

Cells(n, 3) = kk(y)

评论收藏

内容反馈

版权申诉

APei

粉丝: 63
资源: 1万+

Excel VBA_字典套字典实例集锦.zip_Excel VBA_VBA 字典_excel vba实例_vba excel_字

评论0

最新资源

Excel VBA_字典套字典实例集锦.zip_Excel VBA_VBA 字典_excel vba实例_vba excel_字

评论0

Excel VBA_成绩统计分析实例集锦.doc

Excel VBA_批量自动制图表实例集锦.doc

Excel VBA_类代码实例集锦.pdf

Excel VBA_多级动态数据有效性设置实例集锦.doc

Excel VBA_编程难点_版主高手实例集锦.pdf

Excel-VBA-类代码实例集锦.doc

Excel VBA_类代码实例集锦.doc

EXCEL_VBA_完全手册.zip_Excel VBA_excel_vba excel

ExcelQuShu.zip_Excel VBA_VBA提取_VBa_excel vba 数据库_vba excel

VBA 字典实例

Excel VBA 字典法.docx

VBA的字典类，苹果MAC系统可用

VBA字典入门

VBA字典用法集锦及代码详解

vba.rar_Excel VBA_VBA 写入excel_excel_vba excel

EXCEL VBA函数手册.rar_Excel VBA_VBA excel_VBa_excel_vba excel

excel VBA帮助文件.rar_Excel VBA_VBA excel_VBA，Excel_excel_vba exce

Excel_VBA教程.rar_Excel VBA_VBA excel_VBa_excel_excel vba教程

EXCEL_VBA.rar_Excel VBA_Excel_vba_VBa_excel_vba帮助

excel-vba.rar_ vba .xls_Excel VBA_Excel VBA .xls_VBa_excel

ExcelVBA.zip_Excel VBA_Excel 股票_VBA 股票_excel 股票_股票 excel

Excel_VBA.zip_Excel VBA_excel_trunk5wf

Excel-2003-vba.zip_Excel VBA_Excel 宏开发_VBA 格式

Excel-VBA.zip_The First_office vba

excel-VBA-.rar_Excel VBA_cad vba_cad vba

Excel VBA_ADO+SQL实例集锦.zip_Excel VBA_SQL VBA_VBa_excel 教程

vba-sql-Excel.rar_Excel VBA_SQL VBA_VBA SQL_sql excel_sql server

冰河的渗透实战笔记-冰河.pdf

大灰狼远控2021最新版，解压密码222

最新资源