Nhờ nối các Dictionary theo key

Liên hệ QC
G

gpe.vn

Thành viên chính thức
Tham gia
4/1/15
Bài viết
72
Được thích
30
Mình mới tìm hiểu về Dictionary trong vba, Nhờ các bạn giúp mình đoạn code sau:
Vì mình thấy trong Dictionary chỉ có 1 key và tương ứng là 1 item (muốn thêm vào 2 item nữa nhưng ko dc, nên đành tách ra 3 cái Dic là Dic1, Dic2, Dic3)
H mình muốn nối nó lại theo key của nó, sau khi nối kết quả là một mảng, mình có đình kèm file, cảm ơn ccs bạn
Dictionary.png
Dim Dic1 As New Scripting.Dictionary
Dim Dic2 As New Scripting.Dictionary
Dim Dic3 As New Scripting.Dictionary
Sub addDic1()
Dic1.RemoveAll
Dic2.RemoveAll
Dic3.RemoveAll

Dic1.Add "1a", dk6
Dic1.Add "1b", dk8

Dic2.Add "1a", SL10
Dic2.Add "1b", SL12

Dic3.Add "1a", L1500
Dic3.Add "1b", L2000

'1a,dk6,sl10,L1500
'1b,dk8,SL12,L2000

End Sub
 
Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
gpe.vn đã viết:
Mình mới tìm hiểu về Dictionary trong vba, Nhờ các bạn giúp mình đoạn code sau:
Vì mình thấy trong Dictionary chỉ có 1 key và tương ứng là 1 item (muốn thêm vào 2 item nữa nhưng ko dc, nên đành tách ra 3 cái Dic là Dic1, Dic2, Dic3)
H mình muốn nối nó lại theo key của nó, sau khi nối kết quả là một mảng, mình có đình kèm file, cảm ơn ccs bạn
View attachment 301507
Dim Dic1 As New Scripting.Dictionary
Dim Dic2 As New Scripting.Dictionary
Dim Dic3 As New Scripting.Dictionary
Sub addDic1()
Dic1.RemoveAll
Dic2.RemoveAll
Dic3.RemoveAll

Dic1.Add "1a", dk6
Dic1.Add "1b", dk8

Dic2.Add "1a", SL10
Dic2.Add "1b", SL12

Dic3.Add "1a", L1500
Dic3.Add "1b", L2000

'1a,dk6,sl10,L1500
'1b,dk8,SL12,L2000

End Sub
Nhấp chuột vào đây để mở rộng...
Có thể là thế này
Mã: 
Dic1.Add "1a", Array(dk6, sl10, l1500)
 
Upvote 0
Hi, cảm ơn mấy ban, trên các góp ý của mấy bạn mình đã làm lại dc nó thành Mtext, và đã sửa lỗi , chuỗi phải đưa vào dấu nháy " "
Vì 3 objDic này có cùng số phần tử và key giống nhau nên duyệt vào dc, hihi:
Dim Dic1 As New Scripting.Dictionary
Dim Dic2 As New Scripting.Dictionary
Dim Dic3 As New Scripting.Dictionary

Sub go^p_dic()

Dic1.RemoveAll
Dic2.RemoveAll
Dic3.RemoveAll

Dic1.Add "1a", "dk6"
Dic1.Add "1b", "dk8"

Dic2.Add "1a", "SL10"
Dic2.Add "1b", "SL12"

Dic3.Add "1a", "L1500"
Dic3.Add "1b", "L2000"

Dim objKey As Variant
Dim Mtext As String
For Each objKey In objDic1.Keys
Mtext = objKey & objDic1(objKey) & objDic2(objKey) & objDic3(objKey)
Next

End Sub
 
Upvote 0
@gpe.vn
Nếu bạn khai báo & gán như bên dưới thì không phải dấu nháy

Mã: 
Dim Dic1 As New Scripting.Dictionary

Sub gop_dic()

Dic1.RemoveAll

Dim dk6 As String
Dim SL10 As String
Dim L1500 As String

dk6 = "dk6_"
SL10 = "SL10_"
L1500 = "L1500_"


Dic1.Add "1a", Array(dk6, SL10, L1500)

MsgBox Join(Dic1.Items()(0))
End Sub
 
Upvote 0
gpe.vn đã viết:
Mình mới tìm hiểu về Dictionary trong vba, Nhờ các bạn giúp mình đoạn code sau:
Vì mình thấy trong Dictionary chỉ có 1 key và tương ứng là 1 item (muốn thêm vào 2 item nữa nhưng ko dc, nên đành tách ra 3 cái Dic là Dic1, Dic2, Dic3)
H mình muốn nối nó lại theo key của nó, sau khi nối kết quả là một mảng, mình có đình kèm file, cảm ơn ccs bạn
Nhấp chuột vào đây để mở rộng...
Bạn có thể viết 2 Function như sau:
Mã: 
Function MergeDicItem(ByVal sKey As String, ByVal sSep As String, ParamArray Vars() As Variant) As String
    Dim sResult As String, Var1 As Variant, Var2 As Variant
    For Each Var1 In Vars
        If IsArray(Var1) Then
            For Each Var2 In Var1
                sResult = sResult & sSep & Var2.Item(sKey)
            Next
        Else
            sResult = sResult & sSep & Var1.Item(sKey)
        End If
    Next
    MergeDicItem = Mid(sResult, Len(sSep) + 1)
End Function
Function MergeDicItems(ByVal sSep As String, ParamArray Vars() As Variant) As Variant
    Dim aKey As Variant, aResult As Variant, i As Long
    aKey = Vars(0).Keys
    ReDim aResult(UBound(aKey))
    For i = 0 To UBound(aKey)
        aResult(i) = MergeDicItem(aKey(i), sSep, Vars)
        'aResult(i) = aKey(i) & sSep & MergeDicItem(aKey(i), sSep, Vars)
    Next
    MergeDicItems = aResult
End Function
Sử dụng:
Mã: 
    x = MergeDicItem("1b", ", ", Dic1, Dic2, Dic3) 'Lấy 1 item
    arr = MergeDicItems(", ", Dic1, Dic2, Dic3)    'Lấy tất cả items
 
Upvote 0
CHAOQUAY đã viết:
@gpe.vn
Nếu bạn khai báo & gán như bên dưới thì không phải dấu nháy

Mã: 
Dim Dic1 As New Scripting.Dictionary

Sub gop_dic()

Dic1.RemoveAll

Dim dk6 As String
Dim SL10 As String
Dim L1500 As String

dk6 = "dk6_"
SL10 = "SL10_"
L1500 = "L1500_"


Dic1.Add "1a", Array(dk6, SL10, L1500)

MsgBox Join(Dic1.Items()(0))
End Sub
Nhấp chuột vào đây để mở rộng...
UH đúng rồi bạn, nếu là biến là ko có dấu nháy. Code này mình ngắt từ Cad qua cho gọn, Cảm ơn bạn
 
Upvote 0
huuthang_bd đã viết:
Bạn có thể viết 2 Function như sau:
Mã: 
Function MergeDicItem(ByVal sKey As String, ByVal sSep As String, ParamArray Vars() As Variant) As String
    Dim sResult As String, Var1 As Variant, Var2 As Variant
    For Each Var1 In Vars
        If IsArray(Var1) Then
            For Each Var2 In Var1
                sResult = sResult & sSep & Var2.Item(sKey)
            Next
        Else
            sResult = sResult & sSep & Var1.Item(sKey)
        End If
    Next
    MergeDicItem = Mid(sResult, Len(sSep) + 1)
End Function
Function MergeDicItems(ByVal sSep As String, ParamArray Vars() As Variant) As Variant
    Dim aKey As Variant, aResult As Variant, i As Long
    aKey = Vars(0).Keys
    ReDim aResult(UBound(aKey))
    For i = 0 To UBound(aKey)
        aResult(i) = MergeDicItem(aKey(i), sSep, Vars)
        'aResult(i) = aKey(i) & sSep & MergeDicItem(aKey(i), sSep, Vars)
    Next
    MergeDicItems = aResult
End Function
Sử dụng:
Mã: 
    x = MergeDicItem("1b", ", ", Dic1, Dic2, Dic3) 'Lấy 1 item
    arr = MergeDicItems(", ", Dic1, Dic2, Dic3)    'Lấy tất cả items
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn, hàm con lấy item này hay nè, để mình lưu code lại, để nghiền dần chứ đọc chưa hiểu dc liền @@@
 
Upvote 0
Hi các bạn, sẵn tiện mình gởi trọn file lên cho dễ: gồm file Cad và đoạn code
Với chủ để trên mình đã dùng Dictionary và hàm con để trích các thuộc tính của BlockATT và thống kê lại (dạng như thống kê thép)
Đã xong giai đoạn đầu đến đoạn 1, thì trong kết quả no ko Sort A to Z dc, Các bạn giúp mình sort nó trước khi in ra Cad nhé, Xin cảm ơn



Untitled.png




Dim objDic1 As New Scripting.Dictionary
Dim objDic2 As New Scripting.Dictionary
Dim objDic3 As New Scripting.Dictionary
Dim objFSO As New Scripting.FileSystemObject

Sub CT79()
Dim objSS As AcadSelectionSet
Set objSS = ThisDrawing.SelectionSets.Add(ThisDrawing.SelectionSets.Count & Now & "79")

Dim DXF(1) As Integer
Dim DATA(1) As Variant

DXF(0) = 0: DATA(0) = "INSERT"
DXF(1) = 2: DATA(1) = "79_CT_DANG*"

objSS.SelectOnScreen DXF, DATA
Dim objBlkRef As AcadBlockReference
'==============================================================
objDic1.RemoveAll
objDic2.RemoveAll
objDic3.RemoveAll
Dim str0_SH As String, str0_n As Double, str0_dk As Double, str1_L As Double

'-----------------------------------------
For Each objBlkRef In objSS
str0_SH = Fn_GetValueBlockAtt(objBlkRef, "0_SH")
str0_n = Fn_GetValueBlockAtt(objBlkRef, "0_n")
If objDic1.Exists(str0_SH) = False Then
objDic1.Add str0_SH, str0_n
Else
objDic1(str0_SH) = objDic1(str0_SH) + str0_n
End If
Next ' ta da co objDic1( SH,n)
'-----------------------------------------
For Each objBlkRef In objSS
str0_SH = Fn_GetValueBlockAtt(objBlkRef, "0_SH")
str0_dk = Fn_GetValueBlockAtt(objBlkRef, "0_DK")
If objDic2.Exists(str0_SH) = False Then
objDic2.Add str0_SH, str0_dk
Else
objDic2(str0_SH) = objDic2(str0_SH)
End If
Next ' ta da co objDic2( SH,dk)
'-----------------------------------------
For Each objBlkRef In objSS
str0_SH = Fn_GetValueBlockAtt(objBlkRef, "0_SH")
str1_L = Fn_GetValueBlockAtt(objBlkRef, "1_L")
If objDic3.Exists(str0_SH) = False Then
objDic3.Add str0_SH, str1_L
Else
objDic3(str0_SH) = objDic3(str0_SH)
End If
Next ' ta da co objDic3( SH,cDai1Thanh)

'===============================gán các giá tri vao bien strText
Dim objKey As Variant
Dim strText As String
For Each objKey In objDic1.Keys
strText = strText & objKey & "_" & objDic1(objKey) & "_" & objDic2(objKey) & "_" & objDic3(objKey) & Chr(10)
Next
'===============================ghi bien strText ra man hinh cad
Dim varpOint As Variant
varpOint = ThisDrawing.Utility.GetPoint
Dim objMText As AcadMText
Set objMText = ThisDrawing.ModelSpace.AddMText(varpOint, 0, strText)
objMText.Height = 150
objMText.InsertionPoint = varpOint



objSS.Delete
End Sub

Function Fn_GetValueBlockAtt(ByVal objBlockRef As AcadBlockReference, ByVal strTagName As String) As String
Dim arrAttributes As Variant
Dim objAttRef As AcadAttributeReference
Dim i As Integer
Dim strA As String
If objBlockRef.HasAttributes = True Then
arrAttributes = objBlockRef.GetAttributes
For i = 0 To UBound(arrAttributes)
Set objAttRef = arrAttributes(i)
Select Case objAttRef.TagString
Case strTagName
Fn_GetValueBlockAtt = objAttRef.TextString
Exit Function
End Select
Next
End If
End Function
Nhấp chuột vào đây để mở rộng...
 

File đính kèm

  • CAU THANG2007.rar
    105.2 KB · Đọc: 4
Lần chỉnh sửa cuối:
Upvote 0
gpe.vn đã viết:
Hi các bạn, sẵn tiện mình gởi trọn file lên cho dễ: gồm file Cad và đoạn code
Với chủ để trên mình đã dùng Dictionary và hàm con để trích các thuộc tính của BlockATT và thống kê lại (dạng như thống kê thép)
Đã xong giai đoạn đầu đến đoạn 1, thì trong kết quả no ko Sort A to Z dc, Các bạn giúp mình sort nó trước khi in ra Cad nhé, Xin cảm ơn



View attachment 301533
Nhấp chuột vào đây để mở rộng...
File của bạn là cad bao nhiêu vậy
 
Upvote 0
Nhattanktnn đã viết:
hihi, em có hỏi khi nào hàm MergeDicItem chạy đâu nào. Em hỏi khi nào cái Var1 là array ấy, anh đang lường cho trường hợp nào
Nhấp chuột vào đây để mở rộng...
Thì anh trả lời đúng trọng tâm chứ có nói lan man đâu. :D

Biến Vars của hàm MergeDicItems dạng ParamArray nên khi hàm MergeDicItems gọi hàm MergeDicItem thì phải truyền biến mảng vì số phần từ của biến Vars không cố định, không thể tách ra truyền từng Dic được.
Khi hàm MergeDicItems gọi hàm MergeDicItem bằng câu lệnh dưới đây thì biến Vars của hàm MergeDicItem là mảng chứa 1 phần tử mảng.
Mã: 
aResult(i) = MergeDicItem(aKey(i), sSep, Vars)
 
Upvote 0
'#CONST ASARRAY = True

Sub t() ' sub dùng để tét
Dim d As Object
Set d = CreateObject("scripting.dictionary")
PutDicItem d, "1", 1, 2, 3
a = GetDicItem(d, "1")
Debug.Print a(1)
End Sub

Function PutDicItem(ByRef d As Object, ByRef ky As Variant, ParamArray itm() As Variant)
' Puts a combination of items into a key in the dictionary
' Depending on the directive ASARRAY, item can be stored as an array or a concatination of strings
#If ASARRAY Then
d(ky) = itm
#Else
Const delim = "|"
d(ky) = Join(itm, delim)
#End If
End Function

Function GetDicItem(d As Object, ky As Variant)
' Gets the item as stored by PutDicItem
' Return a zero based array
#If ASARRAY Then
GetDicItem = d(ky)
#Else
Const delim = "|"
GetDicItem = Split(d(ky), delim)
#End If
End Function

Muốn dic chứa theo string thì gài dấu nháy ' trước #CONST. Muốn chứa array thì bỏ dấu nháy ấy.
Input và Output gần như in hệt nhau. Tôi chỉ viết đến đây thôi. Cần gì thì sửa lấy.

Vừa viết tắt vừa Tây bồi bắt khiếp.
 
Lần chỉnh sửa cuối:
Upvote 0
VetMini đã viết:
'#CONST ASARRAY = True

Sub t() ' sub dùng để tét
Dim d As Object
Set d = CreateObject("scripting.dictionary")
PutDicItem d, "1", 1, 2, 3
a = GetDicItem(d, "1")
Debug.Print a(1)
End Sub

Function PutDicItem(ByRef d As Object, ByRef ky As Variant, ParamArray itm() As Variant)
' Puts a combination of items into a key in the dictionary
' Depending on the directive ASARRAY, item can be stored as an array or a concatination of strings
#If ASARRAY Then
d(ky) = itm
#Else
Const delim = "|"
d(ky) = Join(itm, delim)
#End If
End Function

Function GetDicItem(d As Object, ky As Variant)
' Gets the item as stored by PutDicItem
' Return a zero based array
#If ASARRAY Then
GetDicItem = d(ky)
#Else
Const delim = "|"
GetDicItem = Split(d(ky), delim)
#End If
End Function

Muốn dic chứa theo string thì gài dấu nháy ' trước #CONST. Muốn chứa array thì bỏ dấu nháy ấy.
Input và Output gần như in hệt nhau. Tôi chỉ viết đến đây thôi. Cần gì thì sửa lấy.

Vừa viết tắt vừa Tây bồi bắt khiếp.
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn, Cho mình hỏi dấu # trước các hàm if, mình ko hiểu đoạn đó ^^
Bài đã được tự động gộp:

VetMini đã viết:
'#CONST ASARRAY = True

Sub t() ' sub dùng để tét
Dim d As Object
Set d = CreateObject("scripting.dictionary")
PutDicItem d, "1", 1, 2, 3
a = GetDicItem(d, "1")
Debug.Print a(1)
End Sub

Function PutDicItem(ByRef d As Object, ByRef ky As Variant, ParamArray itm() As Variant)
' Puts a combination of items into a key in the dictionary
' Depending on the directive ASARRAY, item can be stored as an array or a concatination of strings
#If ASARRAY Then
d(ky) = itm
#Else
Const delim = "|"
d(ky) = Join(itm, delim)
#End If
End Function

Function GetDicItem(d As Object, ky As Variant)
' Gets the item as stored by PutDicItem
' Return a zero based array
#If ASARRAY Then
GetDicItem = d(ky)
#Else
Const delim = "|"
GetDicItem = Split(d(ky), delim)
#End If
End Function

Muốn dic chứa theo string thì gài dấu nháy ' trước #CONST. Muốn chứa array thì bỏ dấu nháy ấy.
Input và Output gần như in hệt nhau. Tôi chỉ viết đến đây thôi. Cần gì thì sửa lấy.

Vừa viết tắt vừa Tây bồi bắt khiếp.
Nhấp chuột vào đây để mở rộng...
Mình có đoạn code, trích các key của objDic1 ra và ghi ra màn hình cad, bạn pro hơn sẵn edit đoạn code của bạn vào giúp. Mình ko nối dc! Thanks các bạn nhiều
Nhấp chuột vào đây để mở rộng...
Dim objDic1 As New Scripting.Dictionary

Sub sort_a2z()
objDic1.RemoveAll

objDic1.Add "1b", "dk6"
objDic1.Add "1a", "dk8"
objDic1.Add "12", "dk6"
objDic1.Add "11", "dk10"
objDic1.Add "9", "dk10"
objDic1.Add "8", "dk10"
'===============================gán các giá tri vao bien strText
Dim objKey1 As Variant
Dim strText As String
For Each objKey1 In objDic1.Keys
strText1 = strText1 & objKey1 & Chr(10)
Next
'===============================ghi bien strText ra man hinh cad
Dim varpOint As Variant
varpOint = ThisDrawing.Utility.GetPoint
Dim objMText As AcadMText
Set objMText = ThisDrawing.ModelSpace.AddMText(varpOint, 0, strText1)
objMText.Height = 150
objMText.InsertionPoint = varpOint

End Sub
Nhấp chuột vào đây để mở rộng...
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

Hai Lúa Miền Tây
  • Question
Hàm groupby và pivot_table của Python trong Excel
    • Thích
    • Yêu thích
Trả lời
14
Đọc
513
ptm0412
ptm0412
vova2209
  • Question
Tìm địa chỉ ô với 2đk và chuyển thành links
Trả lời
0
Đọc
7
vova2209
vova2209
L
Nhờ các bác check và sửa lỗi giúp em file excel ạ.
Trả lời
2
Đọc
63
leuthuy1
L
T
Công thức lấy dữ liệu
Trả lời
2
Đọc
35
tuannguyenmoh
T
Manhhung90
Liệt kê các ngày cộng dồn mong muốn vào 1 ô. Nhờ mọi người giúp mình ạ.
2
Trả lời
39
Đọc
420
Manhhung90
Manhhung90
H
  • Question
Mong giúp code chuyển file xls sang xlsx hàng loạt và không lỗi số liệu
Trả lời
15
Đọc
319
hieug126
H
Hai Lúa Miền Tây
  • Question
Hàm chuyển dữ liệu từ cột sang dòng (Hàm melt của Python trong Excel)
    • Cảm ơn
    • Yêu thích
    • Thích
Trả lời
6
Đọc
332
Hai Lúa Miền Tây
Hai Lúa Miền Tây
test1986
  • Question
Thêm dữ liệu vào ô khi thay đổi dữ liệu trên một ô trên cùng một sheet
Trả lời
9
Đọc
161
test1986
test1986
N
Giúp em công thức lấy dữ liệu không trùng để in phiếu thu bán hàng
Trả lời
4
Đọc
94
nguyenthieny
N
Maika8008
  • Đã giải quyết
[Chia sẻ] Dùng VBA trộn dữ liệu Excel sang file Word mẫu (tương tự chức năng Mail Merge)
    • Thích
    • Yêu thích
    • Cảm ơn
25 26 27
Trả lời
520
Đọc
45K
ngochienbmt
N
tvcneo
  • Question
Nhờ Anh Chị Em giúp mình cách để tạo macro giống như trong file này
Trả lời
11
Đọc
93
Hoàng Tuấn 868
H
jenny12345
tổng hợp dữ liệu theo tháng
Trả lời
9
Đọc
189
jenny12345
jenny12345
tvcneo
Macro hoạt động ngân hàng
Trả lời
9
Đọc
66
Hoàng Tuấn 868
H
67k8899
Xin được giúp đỡ! Cách đánh số thứ tự tự động theo 2 điều kiện
Trả lời
2
Đọc
97
67k8899
67k8899
vib1191
Nhờ giúp đỡ công thức dò tìm và tính tổng
Trả lời
0
Đọc
54
vib1191
vib1191
H
Có thể mở file Excel mới sẽ Zoom mặc định 150% không?
Trả lời
2
Đọc
102
cantl
C
T
Nhờ hỗ trợ công thức ghép dữ liệu
Trả lời
5
Đọc
137
HieuCD
H
jenny12345
hàm để tham chiếu từ file này sang file khác
Trả lời
2
Đọc
110
jenny12345
jenny12345
H
  • Question
Lập trình cộng gộp phân cấp tài khoản kế toán
Trả lời
4
Đọc
232
hieuvietmy2020
H
Vân Vân Ngô
xóa các shape ẩn trong sheet excel
Trả lời
14
Đọc
20K
PerSP
PerSP
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom