Giúp viết code dò tìm và nối chuỗi (1 người xem)

  • Thread starter Thread starter Hong.Van
  • Ngày gửi Ngày gửi
Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
Hong.Van

Hong.Van

Busy
Tham gia
7/5/12
Bài viết
2,330
Được thích
1,767
Em chào Thầy cô và anh chị!
Giúp em viết code dò tìm và nối chuỗi như sau:
Code cho kết qủa từ Cell J9 trở xuống tại Sheet TH:
Tại J9 em có cthức như sau:
PHP: 
=IF(B9<>"";(VLOOKUP(H9&I9;DG;2;0)&" "&G9&"_"&F9);"")
Trong đó DG là name của sheet MA
PHP: 
=Ma!$L$5:$N$19
Vì dữ liệu của em rất nhiều nên giúp em viết code dưới dạng mảng
Trong bài của em cột B của Sheet TH là liên tục!
Em cũng đã làm nhưng vẫn chưa được, vì vậy mong Thầy cô & anh chị giúp. Xin cảm ơn!
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Bạn tham khảo Code này nhé
Mã: 
Sub Timkiem()
Dim ArrPN, ArrData, DicArrPN, Dic As Object, i, k  As Integer


ArrPN = Sheet1.Range("L5:M" & Range("M65536").End(3).Row)
ArrData = Sheet2.Range("A9:J" & Range("B65536").End(3).Row)
ReDim DicArrPN(1 To UBound(ArrPN, 1), 1 To 2)


Set Dic = CreateObject("Scripting.Dictionary")


With Dic
    For i = 1 To UBound(ArrPN, 1)
        If Not .exists(ArrPN(i, 1)) Then 'Gan Item cho Dic
            k = k + 1
            .Add ArrPN(i, 1), k
            DicArrPN(k, 1) = ArrPN(i, 1) 'Dua du lieu vao DicArrPN
            DicArrPN(k, 2) = ArrPN(i, 2)
        End If
    Next
'Truy xuat tu Arrdata toi Dic
    For i = 1 To UBound(ArrData, 1)
        If ArrData(i, 2) <> "" And .exists(ArrData(i, 8) & ArrData(i, 9)) Then
            ArrData(i, 10) = DicArrPN(.Item(ArrData(i, 8) & ArrData(i, 9)), 2) & " " & ArrData(i, 7) & " " & ArrData(i, 6)
        End If
    Next
End With


'Xuat vung Data ra Sheets("TH")
Sheet2.[a9].Resize(UBound(ArrData), 10) = ArrData


End Sub
 
Upvote 0
dhn46 đã viết:
Bạn tham khảo Code này nhé
Nhấp chuột vào đây để mở rộng...

Sao lại làm vậy, với dữ liệu đã có thì copy rồi PasteSpeacial là xong. Còn dữ liệu mới thì áp dụng WorkSheet_Change mà điền dữ liệu, như vậy chỉ có 1 ô thôi nên không có cảm giác về tốc độ đâu. Nhập đến đâu điền đến đó vậy là ổn
 
Upvote 0
Hong.Van đã viết:
Em chào Thầy cô và anh chị!
Giúp em viết code dò tìm và nối chuỗi như sau:
Code cho kết qủa từ Cell J9 trở xuống tại Sheet TH:
Tại J9 em có cthức như sau:
PHP: 
=IF(B9<>"";(VLOOKUP(H9&I9;DG;2;0)&" "&G9&"_"&F9);"")
Trong đó DG là name của sheet MA
PHP: 
=Ma!$L$5:$N$19
Vì dữ liệu của em rất nhiều nên giúp em viết code dưới dạng mảng
Trong bài của em cột B của Sheet TH là liên tục!
Em cũng đã làm nhưng vẫn chưa được, vì vậy mong Thầy cô & anh chị giúp. Xin cảm ơn!
Nhấp chuột vào đây để mở rộng...
Dùng Find Method đây:
Mã: 
Sub Test()
  Dim Find_Table As Range, aSrcData, rFind As Range
  Dim lR As Long
  Dim sTmp As String, sFindVal As String, sRes As String
  On Error Resume Next
  Set Find_Table = Sheets("Ma").Range("L5:M20000")
  With Sheets("TH").Range("B9:J20000")
    aSrcData = .Value
    For lR = 1 To UBound(aSrcData, 1)
      sTmp = CStr(aSrcData(lR, 1))
      If Len(sTmp) Then
        sFindVal = aSrcData(lR, 7) & aSrcData(lR, 8)
        Set rFind = Find_Table.Find(sFindVal, , xlValues, xlWhole)
        If Not rFind Is Nothing Then
          sRes = rFind.Offset(, 1).Value
          aSrcData(lR, 9) = sRes & " " & aSrcData(lR, 6) & "_" & aSrcData(lR, 5)
        End If
      End If
    Next
    .Value = aSrcData
  End With
End Sub
Chỉ có 1/2 là mảng thôi
 
Upvote 0
Em xin cảm ơn các thầy & anh đã giúp đỡ
-----------------
Em mới lò mò ra xong, code của em có thêm một số điều kiện, Em viết kiểu này không biết có đúng không
Mã: 
Sub DienGiai()
    Dim i As Long
    Dim arrRes, arrSrc
    Dim n1 As Range, rTmp As Range


    With ActiveSheet
        arrSrc = .Range(.[B9], .[B65536].End(3)).Resize(, 9).Value
    End With


    With Sheets("MA")
        Set n1 = .Range(.[L5], .[L200].End(3))
    End With
    ReDim arrRes(1 To UBound(arrSrc, 1), 1 To 1)
    For i = 1 To UBound(arrSrc, 1)
        Set rTmp = n1.Find(arrSrc(i, 7) & arrSrc(i, 8), , xlValues, xlWhole)
        If Not rTmp Is Nothing Then
            If arrSrc(i, 5) = "" And arrSrc(i, 6) = "" Then
                arrRes(i, 1) = rTmp.Offset(, 1)
            ElseIf arrSrc(i, 5) = "" Then
                arrRes(i, 1) = rTmp.Offset(, 1) & " " & arrSrc(i, 6)
            ElseIf arrSrc(i, 6) = "" Then
                arrRes(i, 1) = rTmp.Offset(, 1) & " " & "_" & arrSrc(i, 5)
            Else
                arrRes(i, 1) = rTmp.Offset(, 1) & " " & arrSrc(i, 6) & "_" & arrSrc(i, 5)
            End If
        End If
    Next i
    ActiveSheet.Range("J9").Resize(UBound(arrRes, 1)).Value = arrRes
End Sub
Code này em dựa code của Thầy Ndu giúp em lúc trước
--------------------
Em sẽ nghiên cứu kỹ hơn code của Thầy & các bạn
 
Upvote 0
Theo mình nếu để điền toàn bộ diễn giải có lẽ thế này là được, thậm chí tối ưu về tốc độ là đằng khác

[GPECODE=vb]Sub Reset_Data()
Dim Buttoan, PSinh, Dgiai(), i, Dic As Object
Buttoan = Sheet1.Range("L5:M" & Sheet1.Range("M65536").End(3).Row)
PSinh = Sheet2.Range("A9:J" & Sheet2.Range("B65536").End(3).Row)
ReDim Dgiai(1 To UBound(PSinh, 1), 1 To 1)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Buttoan, 1)
If Not Dic.exists(Trim(Buttoan(i, 1))) Then Dic.Add Trim(Buttoan(i, 1)), Buttoan(i, 2)
Next
On Error Resume Next
For i = 1 To UBound(PSinh, 1)
If PSinh(i, 2) <> 0 Then Dgiai(i, 1) = Dic.Item(PSinh(i, 8) _
& PSinh(i, 9)) & " " & PSinh(i, 7) & IIf(PSinh(i, 6) <> "", "_" & PSinh(i, 6), "")
Next
Sheet2.[J9].Resize(UBound(Dgiai, 1)) = Dgiai
Set Dic = Nothing
End Sub[/GPECODE]
 
Upvote 0
sealand đã viết:
Theo mình nếu để điền toàn bộ diễn giải có lẽ thế này là được, thậm chí tối ưu về tốc độ là đằng khác

[GPECODE=vb]Sub Reset_Data()
Dim Buttoan, PSinh, Dgiai(), i, Dic As Object
Buttoan = Sheet1.Range("L5:M" & Sheet1.Range("M65536").End(3).Row)
PSinh = Sheet2.Range("A9:J" & Sheet2.Range("B65536").End(3).Row)
ReDim Dgiai(1 To UBound(PSinh, 1), 1 To 1)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Buttoan, 1)
If Not Dic.exists(Trim(Buttoan(i, 1))) Then Dic.Add Trim(Buttoan(i, 1)), Buttoan(i, 2)
Next
On Error Resume Next
For i = 1 To UBound(PSinh, 1)
If PSinh(i, 2) <> 0 Then Dgiai(i, 1) = Dic.Item(PSinh(i, 8) _
& PSinh(i, 9)) & " " & PSinh(i, 7) & IIf(PSinh(i, 6) <> "", "_" & PSinh(i, 6), "")
Next
Sheet2.[J9].Resize(UBound(Dgiai, 1)) = Dgiai
Set Dic = Nothing
End Sub[/GPECODE]
Nhấp chuột vào đây để mở rộng...
Em thấy mấy bài Dic gần như giải quyết hầu hết các bài khó
Em cũng đã đọc một số bài như Ðề tài: Tổng quan về Scripting.Dictionary

và một số bài khác, nhưng cũng chưa hiểu gì nhiều!
Thầy cô & các Anh giúp em giải thích code trên để em hiểu hơn!
Em cảm ơn!
 
Upvote 0
Đối với Code bài này thì không có gì để nói nhiều, chỉ có vấn đề dùng Dictionary. Không phải Dictionary giải quyết được mọi vấn đề khó, mà là ta lợi dụng thế mạnh của nó phục vụ mục đích của mình mà thôi. Yêu cầu chính của bài là tra mã định khoản để lấy Diễn giải (Tiếp đầu ngữ). Với các hàm Vlookup, Match, hay cấu trúc For...Next... hay phương thức Find thực chất là vẫn rà từ đầu Danh sách đến khi gặp mã thì lấy. Trong khi đó, Dic. nó có phương thức: Dic.Item(Key) thì nó trả về Item của Key. Nói gọn lại, là lấy đích danh chứ không phải dò tìm nữa, giống như như mảng Arr(n) ta lấy Arr(3) chẳng hạn. Vậy là tốc độ tăng lên rất nhiều. Đây là chiêu mình rất thích dùng cho các bài toán xuất nhập tồn, công nợ hay tổng hợp phát sinh Tài khoản kế toán. Đảm bảo nó nhanh và chính xác hơn các cách khác nhiều.

Ngoài Dictionary, nhiều khi người ta còn dùng Listview để sử lý nữa vì nó cơ chế tìm kiếm Find riêng và khả năng Sort dữ liệu theo cột. Việc sử dụng Listview cũng theo phương thức CreateObject mà AnhTuan1066 đã có bài tương tự về Combobox rồi. Khi nào có dịp ta tìm hiểu thêm.
 
Upvote 0
GIÚP EM SỬA CODE CỦA CỘT J CỦA SHEET TH
----------------------------
Code cũ của em
Mã: 
Sub DienGiai_Old()
    Dim i As Long
    Dim arrRes, arrSrc
    Dim n1 As Range, rTmp As Range


    With ActiveSheet
        arrSrc = .Range(.[B9], .[B65536].End(3)).Resize(, 11).Value
    End With


    With Sheets("MA")
        Set n1 = .Range(.[L5], .[L200].End(3))
    End With
    ReDim arrRes(1 To UBound(arrSrc, 1), 1 To 1)
    For i = 1 To UBound(arrSrc, 1)
        Set rTmp = n1.Find(arrSrc(i, 7) & arrSrc(i, 8), , xlValues, xlWhole)
        If Not rTmp Is Nothing Then
            If arrSrc(i, 7) = 1561 Or arrSrc(i, 7) = 155 Or arrSrc(i, 7) = 152 Or arrSrc(i, 7) = 153 Then


                arrRes(i, 1) = rTmp.Offset(, 1) & " " & arrSrc(i, 11) & " c" & ChrW(7911) & "a " & arrSrc(i, 6)
            Else
                arrRes(i, 1) = rTmp.Offset(, 1) & " " & arrSrc(i, 11) & " cho " & arrSrc(i, 6)
            End If
        End If


    Next i
    ActiveSheet.Range("J9").Resize(UBound(arrRes, 1)).Value = arrRes
End Sub
Em giải thích code trên như sau:
Ví dụ em lấy dòng 15 của Sheet TH như sau:
Ghép Cell H15 và I15 để dò tìm bên Sheet MA của cột L, nếu tìm thấy thì lấy kết qủa của cột kế bên và nối với một số cell L15 và G15 để cho kết qủa tại Cell J15
(và thêm một số điều kiện linh tinh khác)
-------------------
Bây giờ code mới em như sau
Trước đây Cell G15 là tên khách hàng, bây giờ em đổi G15 là Mã KH. Vì thế trước khi nối chuỗi thì sẽ dùng G15 để tìm Bên Sheet Mã tại cột BE, nếu tìm thấy thì sẽ lệch qua cột BH để lấy kết qủa và nối chuỗi giống như trên
---------------
Cụ thể code cũ chạy cho kết qủa tại cell J15 của Sheet TH là "Nhập Vỏ xe của M013"
Mà Mả KH M013 dò bên Sheet Mã là cell BE126 và sẽ lấy kết qủa cell BH126 là: "Cty TNHH DV Tân Minh Tài" và vẫn nối chuỗi như trên
Như vậy khi chạy code sẽ cho kết qủa đúng là "Nhập Vỏ xe của Cty TNHH DV Tân Minh Tài"
-----------
Code mới em viết như sau
Mã: 
Sub DienGiai_New()
    Dim i As Long
    Dim arrRes, arrSrc
    Dim n1 As Range, rTmp As Range
    Dim n2 As Range, rTmp1 As Range
    With ActiveSheet
        arrSrc = .Range(.[B9], .[B65536].End(3)).Resize(, 11).Value
    End With


    With Sheets("MA")
        Set n1 = .Range(.[L5], .[L200].End(3))
        Set n2 = .Range(.[BE10], .[BE2000].End(3))
    End With
    
    ReDim arrRes(1 To UBound(arrSrc, 1), 1 To 1)
    For i = 1 To UBound(arrSrc, 1)
        Set rTmp = n1.Find(arrSrc(i, 7) & arrSrc(i, 8), , xlValues, xlWhole)
        Set rTmp1 = n2.Find(arrSrc(i, 6), , xlValues, xlWhole)
        If Not rTmp Or rTmp1 Is Nothing Then
            If arrSrc(i, 7) = 1561 Or arrSrc(i, 7) = 155 Or arrSrc(i, 7) = 152 Or arrSrc(i, 7) = 153 Then


                arrRes(i, 1) = rTmp.Offset(, 1) & " " & arrSrc(i, 11) & " c" & ChrW(7911) & "a " & rTmp1.Offset(, 3)
            Else
                arrRes(i, 1) = rTmp.Offset(, 1) & " " & arrSrc(i, 11) & " cho " & rTmp1.Offset(, 3)
            End If
        End If
    Next i
    ActiveSheet.Range("J9").Resize(UBound(arrRes, 1)).Value = arrRes
End Sub
Nhưng code này báo lỗi, em tìm vẫn chưa tìm ra! Vì vậy em nhờ Thầy cô & anh chị giúp em sửa code trên
---------------
Trong File em có 2 nút cho code cũ & mới
Em cảm ơn!
 

File đính kèm

Upvote 0
Em đã tìm ra lỗi rồi! Xin cảm ơn đã đọc bài
Mã: 
If Not rTmp Is Nothing Then
            If Not rTmp1 Is Nothing Then
                If arrSrc(i, 7) = 1561 Or arrSrc(i, 7) = 155 Or arrSrc(i, 7) = 152 Or arrSrc(i, 7) = 153 Then


                    arrRes(i, 1) = rTmp.Offset(, 1) & " " & arrSrc(i, 11) & " c" & ChrW(7911) & "a " & rTmp1.Offset(, 3)
                Else
                    arrRes(i, 1) = rTmp.Offset(, 1) & " " & arrSrc(i, 11) & " cho " & rTmp1.Offset(, 3)
                End If
            End If
        End If
 
Upvote 0
Hong.Van đã viết:
-----------
Code mới em viết như sau
Mã: 
Sub DienGiai_New()
    
        Set rTmp = n1.Find(arrSrc(i, 7) & arrSrc(i, 8), , xlValues, xlWhole)
        Set rTmp1 = n2.Find(arrSrc(i, 6), , xlValues, xlWhole)
        [COLOR=#ff0000][B]If Not rTmp Or rTmp1 Is Nothing Then[/B][/COLOR]
            
End Sub
Nhưng code này báo lỗi, em tìm vẫn chưa tìm ra! Vì vậy em nhờ Thầy cô & anh chị giúp em sửa code trên
---------------
Trong File em có 2 nút cho code cũ & mới
Em cảm ơn!
Nhấp chuột vào đây để mở rộng...
Sai chổ màu đỏ
Sửa thành: If (Not rTmp Is Nothing) And (Not rTmp1 Is Nothing) Then nhé
Not rTmp Is Nothing (đ/k1) nghĩa là tìm thấy rTmp
Not rTmp1 Is Nothing (đ/k2) nghĩa là tìm thấy rTmp1
Cả 2 vế này phải cùng =TRUE thì mới làm các code bên dưới
Tức IF đ/k1 and đ/k2 then ---> Đúng chứ
 
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

X
add-in báo lỗi mỗi khi mở file (4 người xem)
Trả lời
0
Đọc
3
Xike20009x
X
K
cố định, không thay đổi kích thước, ( fit) độ rộng dòng, cột (2 người xem)
Trả lời
1
Đọc
16
HeSanbi
HeSanbi
HeSanbi
  • Question Question
VBA nâng cao: Nhúng tập tin vào trang tính hoặc trích xuất chúng nhanh chóng (1 người xem)
    • Thích
    • Cảm ơn
Trả lời
1
Đọc
205
HeSanbi
HeSanbi
NguyenBaChien
Nhờ tách lấy số và tính tổng có điều kiện của dãy số (3 người xem)
Trả lời
3
Đọc
60
NguyenBaChien
NguyenBaChien
H
xin mọi người giúp em làm tròn với ạ
Trả lời
5
Đọc
104
vietduc147258
V
L
[Xin giúp] Cách copy công thức từ bảng tham chiếu vào một ô
Trả lời
2
Đọc
49
Lá chanh
L
hoangluongvinh
Cách nhặt các dữ liệu bị trùng của 1 đối tượng (2 người xem)
Trả lời
8
Đọc
173
tt_kimbai
T
N
  • Question Question
Cách viết tiếng việt có dấu trong msgbox,....... Hoàn toàn mới (1 người xem)
    • Thích
2
Trả lời
35
Đọc
5K
ligktit
L
T
  • Question Question
Lọc dữ liệu có nhiều điều kiện
Trả lời
2
Đọc
123
tt_kimbai
T
longhungvnpost
cả nhà giúp e tạo ô tìm kiếm gợi ý trong danh sách nhé (2 người xem)
Trả lời
3
Đọc
107
longhungvnpost
longhungvnpost
S
Cố định độ rộng/ cao của cột/hàng? (2 người xem)
Trả lời
12
Đọc
17K
khanhnth02
K
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
15 16 17
Trả lời
329
Đọc
26K
tt_kimbai
T
dung1983
Hỏi về import - Table/ XML cho bảng, trang có chứa JS
Trả lời
0
Đọc
63
dung1983
dung1983
HeSanbi
  • Đã giải quyết
VBA_FastCode v2.22 - Công cụ học và viết mã VBA một cách nhanh nhất (*27/10/2023) (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
2 3
Trả lời
51
Đọc
15K
HeSanbi
HeSanbi
Manhhung90
Mail merge in ấn theo từng trang mong muốn.
Trả lời
1
Đọc
109
Hoàng Tuấn 868
H
L
Xin giúp đỡ đổi màu chữ trong mathtype powerpoint sang màu đen
Trả lời
4
Đọc
129
LINHCM
L
ongke0711
  • Question Question
Form Đăng nhập và phân quyền cơ bản (1 người xem)
    • Thích
2 3
Trả lời
40
Đọc
5K
Gà Công Nghệ
Gà Công Nghệ
vnxgiokinhtoi
Nhờ giúp đỡ công thức lưu dữ liệu và mở lại dữ liệu cũ đã save
Trả lời
6
Đọc
214
DeTong
D
A
  • Question Question
Addin lúc hiện lúc không
Trả lời
1
Đọc
110
anhdepjai
A
T
  • Question Question
Ẩn hiện các sheet khi click vào HyperLink
Trả lời
6
Đọc
302
Gà Công Nghệ
Gà Công Nghệ
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365
Back
Top Bottom