Xin mã VBA như hàm Vloopkup nhưng lấy được cả formats , comments của ô được tìm kiếm

Liên hệ QC

kienphamiuh

Thành viên chính thức
Tham gia
8/12/18
Bài viết
66
Được thích
11
-em có 1 vấn đề nhờ các anh chị trong group giúp ạ
-em có 1 File excel ( sheep 1 là "thông tin", sheep 2 là "file tổng")
+ em sử dụng làm Vlookup để lấy thông tin từ "file tổng" chuyển qua file " thông tin" dựa vào Mã HV
+ Vấn đề em gặp là Vlookup chỉ lấy được giá trị mà không lấy đc: màu sắc của ô ( ô được tô màu vàng ), comment, màu sắc của chữ ( chữ màu đỏ ).
- em mong anh chị giúp tạo 1 hàm Xlookup có chức năng như Vlookup nhưng lấy được giá trị và cả (màu sắc của ô,comment, màu sắc của chữ ) , còn nếu không thể làm 1 hàm như Xlookup anh chị giúp em viết code lấy giá trị và màu sắc của ô,comment, màu sắc của chữ dựa vào mã HV trong file " thông tin" ạ
vd: =Xlookup ( X, Y ,Z ,0 or 1)
X là Giá trị dùng để dò tìm
Y là Bảng giá trị dò
Z là Thứ tự của cột cần lấy dữ liệu trên bảng giá trị dò
0 là giá trị tuyệt đối
X Y Z là các giá trị mình nhập ( linh động như ham vlookup ), mong các anh chị giúp, em cảm ơn nhiều " trong code có giải thích code thì càng tốt ạ "

em có viết 1 đoan VBA như sau :
Function Xlookup(cn As String)
Xlookup = Sheet2.Range("a:a").Find(cn).Offset(, 1).Value
End Function
nhưng nhựơc điểm là không linh động cột cần lấy, mỗi lần lấy phải vào code sửa offset và không lấy được màu sắc của ô,comment, màu sắc của chữ ( còn thua xài vlookup nữa anh chị ạ :(( )
 

File đính kèm

  • file.xlsx
    12.5 KB · Đọc: 18
Bạn chạy "Sub test" nhé,code hỏi điều kiện lấy: nếu muốn lấy fromat và giá trị chọn yes, còn chỉ mỗi giá trị không thì chọn No, hủy bỏ chọn cancel:
Mã:
Private Sub sGPE(Optional ByVal format As Boolean = False)
Dim lastRow As Long, r1 As Long, r2 As Long, shSrc As Worksheet, shDest As Worksheet, csdl(), data(), result(), text As String
    Set shDest = Worksheets("FILE GUI")
    With shDest
'        xoa ket qua cu
        lastRow = .Cells(Rows.Count, "J").End(xlUp).Row
        If lastRow >= 12 Then
            With .Range("J12:K" & lastRow)
                .Clear
                .Borders.LineStyle = xlContinuous
            End With
        End If
        lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
'        neu khong co du lieu thi ket thuc cuoc choi, nguoc lai lay vao mang data
        If lastRow < 12 Then Exit Sub
        data = .Range("B12:B" & lastRow + 1).Value
'        mang ket qua
        If Not format Then ReDim result(1 To UBound(data) - 1, 1 To 2)
    End With
    Set shSrc = Worksheets("DANH SACH TONG")
    With shSrc
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
'        neu khong co du lieu thi ket thuc cuoc choi, nguoc lai lay vao mang csdl
        If lastRow < 4 Then Exit Sub
        csdl = .Range("A4:J" & lastRow).Value
    End With
    For r1 = 1 To UBound(data) - 1
        text = data(r1, 1)
        For r2 = 1 To UBound(csdl)
            If csdl(r2, 1) = text Then
                If format Then
                    shSrc.Cells(3 + r2, "I").Resize(, 2).Copy shDest.Cells(11 + r1, "J")
                Else
                    result(r1, 1) = csdl(r2, 8)
                    result(r1, 2) = csdl(r2, 9)
                End If
                Exit For
            End If
        Next r2
    Next r1
    If Not format Then shDest.Range("J12").Resize(UBound(result), 2).Value = result
End Sub

Sub test()
    Select Case Application.Assistant.DoAlert("Giaiphapexcel.com", TbaoLuachon, msoAlertButtonYesNoCancel, msoAlertIconWarning, 0, 0, False)
        Case vbYes:       sGPE True   'lay gia tri va format
        Case vbNo:        sGPE        'chi lay gia tri
        Case vbCancel:    Exit Sub    'thoat khong lam gi
    End Select
End Sub

Function TbaoLuachon()
    TbaoLuachon = "B" & ChrW(7841) & "n c" & ChrW(243) & " mu" & ChrW(7889) & "n l" & ChrW(7845) & "y c" & ChrW(7843) & " Format kh" & ChrW(244) & "ng?"
End Function
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn chạy "Sub test" nhé,code hỏi điều kiện lấy: nếu muốn lấy fromat và giá trị chọn yes, còn chỉ mỗi giá trị không thì chọn No, hủy bỏ chọn cancel:
Mã:
Private Sub sGPE(Optional ByVal format As Boolean = False)
Dim lastRow As Long, r1 As Long, r2 As Long, shSrc As Worksheet, shDest As Worksheet, csdl(), data(), result(), text As String
    Set shDest = Worksheets("FILE GUI")
    With shDest
'        xoa ket qua cu
        lastRow = .Cells(Rows.Count, "J").End(xlUp).Row
        If lastRow >= 12 Then
            With .Range("J12:K" & lastRow)
                .Clear
                .Borders.LineStyle = xlContinuous
            End With
        End If
        lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
'        neu khong co du lieu thi ket thuc cuoc choi, nguoc lai lay vao mang data
        If lastRow < 12 Then Exit Sub
        data = .Range("B12:B" & lastRow + 1).Value
'        mang ket qua
        If Not format Then ReDim result(1 To UBound(data) - 1, 1 To 2)
    End With
    Set shSrc = Worksheets("DANH SACH TONG")
    With shSrc
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
'        neu khong co du lieu thi ket thuc cuoc choi, nguoc lai lay vao mang csdl
        If lastRow < 4 Then Exit Sub
        csdl = .Range("A4:J" & lastRow).Value
    End With
    For r1 = 1 To UBound(data) - 1
        text = data(r1, 1)
        For r2 = 1 To UBound(csdl)
            If csdl(r2, 1) = text Then
                If format Then
                    shSrc.Cells(3 + r2, "I").Resize(, 2).Copy shDest.Cells(11 + r1, "J")
                Else
                    result(r1, 1) = csdl(r2, 8)
                    result(r1, 2) = csdl(r2, 9)
                End If
                Exit For
            End If
        Next r2
    Next r1
    If Not format Then shDest.Range("J12").Resize(UBound(result), 2).Value = result
End Sub

Sub test()
    Select Case Application.Assistant.DoAlert("Giaiphapexcel.com", TbaoLuachon, msoAlertButtonYesNoCancel, msoAlertIconWarning, 0, 0, False)
        Case vbYes:       sGPE True   'lay gia tri va format
        Case vbNo:        sGPE        'chi lay gia tri
        Case vbCancel:    Exit Sub    'thoat khong lam gi
    End Select
End Sub

Function TbaoLuachon()
    TbaoLuachon = "B" & ChrW(7841) & "n c" & ChrW(243) & " mu" & ChrW(7889) & "n l" & ChrW(7845) & "y c" & ChrW(7843) & " Format kh" & ChrW(244) & "ng?"
End Function
Cảm ơn OT mình biết phải sửa code lại thế nào rồi :)
 
Upvote 0
@Nguyễn Hoàng Oanh Thơ bạn cho mình hỏi đoạn code result(r1, 1) = csdl(r2, 8) và result(r1, 2) = csdl(r2, 9) nó có ý nghĩa gì vậy bạn ?
Mã:
For r1 = 1 To UBound(data) - 1
        text = data(r1, 1)
        For r2 = 1 To UBound(csdl)
            If csdl(r2, 1) = text Then
                If format Then
                    shSrc.Cells(3 + r2, "I").Resize(, 2).Copy shDest.Cells(11 + r1, "J")
                Else
                    result(r1, 1) = csdl(r2, 8) // câu này với câu dưới mang ý nghĩa gì, số 8,9 có công dụng gì ạ ?
                    result(r1, 2) = csdl(r2, 9)
                End If
                Exit For
            End If
        Next r2
    Next r1
    If Not format Then shDest.Range("J12").Resize(UBound(result), 2).Value = result
 
Upvote 0
@Nguyễn Hoàng Oanh Thơ bạn cho mình hỏi đoạn code result(r1, 1) = csdl(r2, 8) và result(r1, 2) = csdl(r2, 9) nó có ý nghĩa gì vậy bạn ?
Mã:
For r1 = 1 To UBound(data) - 1
        text = data(r1, 1)
        For r2 = 1 To UBound(csdl)
            If csdl(r2, 1) = text Then
                If format Then
                    shSrc.Cells(3 + r2, "I").Resize(, 2).Copy shDest.Cells(11 + r1, "J")
                Else
                    result(r1, 1) = csdl(r2, 8) // câu này với câu dưới mang ý nghĩa gì, số 8,9 có công dụng gì ạ ?
                    result(r1, 2) = csdl(r2, 9)
                End If
                Exit For
            End If
        Next r2
    Next r1
    If Not format Then shDest.Range("J12").Resize(UBound(result), 2).Value = result

Xin chào kienphamiuh,
OT cũng chưa nắm chắc kiến thức về mảng cũng như về khái niệm về các từ ngữ của mảng nên tạm thời OT viết theo cách OT hiểu nhé:

Mã:
Private Sub sGPE(Optional ByVal format As Boolean = False)
Dim lastRow As Long, r1 As Long, r2 As Long, shSrc As Worksheet, shDest As Worksheet, csdl(), data(), result(), text As String
    Set shDest = Worksheets("FILE GUI")
    With shDest
'        xoa ket qua cu
        lastRow = .Cells(Rows.Count, "J").End(xlUp).Row
        If lastRow >= 12 Then
            With .Range("J12:K" & lastRow)
                .Clear
                .Borders.LineStyle = xlContinuous
            End With
        End If
        lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
'        neu khong co du lieu thi ket thuc cuoc choi, nguoc lai lay vao mang data
        If lastRow < 12 Then Exit Sub
        data = .Range("B12:B" & lastRow + 1).Value ' dua du lieu cua sheet"FILE GUI" vao mang data
'        mang ket qua
        If Not format Then ReDim result(1 To UBound(data) - 1, 1 To 2) ' neu khong lay format thi khai bao kich thuoc cua mang result
        '1 To 2: chieu tu trai sang fai la co 2 cot (tuong uong voi cot J(cot1) va K(cot2) tren sheet"FILE GUI")
    'result la mang ghi ket qua so sanh duoc
    End With
    Set shSrc = Worksheets("DANH SACH TONG")
    With shSrc
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
'        neu khong co du lieu thi ket thuc cuoc choi, nguoc lai lay vao mang csdl
        If lastRow < 4 Then Exit Sub
        csdl = .Range("A4:J" & lastRow).Value ' dua du lieu cua sheet"DANH SACH TONG" vao mang csdl
    End With
    For r1 = 1 To UBound(data) - 1 'duyet gia tri trong mang data
        text = data(r1, 1) 'moi vong lap gan gia tri tim dc vao bien text (bien tam thoi hay con goi la trung gian)
        '1: cot dau tien trong mang data,tuong ung voi cot B tren sheet"FILE GUI"
        For r2 = 1 To UBound(csdl) 'duyet gia tri trong mang csdl
            If csdl(r2, 1) = text Then 'neu tim duoc gia tri trong mang csdl(r2, 1) = text
            '1: cot dau tien trong mang csdl,tuong ung voi cot A tren sheet"DANH SACH TONG"
                If format Then 'Neu lay ca format
                    shSrc.Cells(3 + r2, "I").Resize(, 2).Copy shDest.Cells(11 + r1, "J")
                    'bat dau tu dong 3 , cot I trong sheet "DANH SACH TONG" + voi thu tu cua giatri tim duoc trong mang csdl
                    'Resize(, 2) : tu cot I que't sang phai 1 cot se thanh I:J dong 3+r2
                Else
                    'xet trong mang csdl tuong duong voi xet trong sheet"DANH SACH TONG"
                    result(r1, 1) = csdl(r2, 8) ' tinh tu cot A den J tuong ung voi 1,2,...9 (cot 8 = H)
                    result(r1, 2) = csdl(r2, 9) ' tinh tu cot A den J tuong ung voi 1,2,...9 (cot 9 = I)
                End If
                Exit For
            End If
        Next r2
    Next r1
    'neu khong lay format thi se dua mang result xuong bat dau tu o J12
    If Not format Then shDest.Range("J12").Resize(UBound(result), 2).Value = result
End Sub

result(r1, 1) = csdl(r2, 8) // câu này với câu dưới mang ý nghĩa gì, số 8,9 có công dụng gì ạ ?
result(r1, 2) = csdl(r2, 9)
Bạn thử thay số 8 thành số 9 và thay số 9 thành số 10 ở 2 dòng trên thì khi chạy Sub tes:
Mã:
Sub test()
    Select Case Application.Assistant.DoAlert("Giaiphapexcel.com", TbaoLuachon, msoAlertButtonYesNoCancel, msoAlertIconWarning, 0, 0, False)
        Case vbYes:       sGPE True   'lay gia tri va format
        Case vbNo:        sGPE        'chi lay gia tri
        Case vbCancel:    Exit Sub    'thoat khong lam gi
    End Select
End Sub
sẽ thấy kết quả giá trị trả về khi chọn yes hoặc no đều như nhau.
Chỉ khác nhau về lấy format và không lấy format.

Bạn muốn hiểu rõ về mảng thì có thể hỏi thêm bác Siwtom, người viết đoạn code trên ở bài 29:
https://www.giaiphapexcel.com/diendan/threads/xin-mã-vba-như-hàm-vloopkup-nhưng-lấy-được-cả-formats-comments-của-ô-được-tìm-kiếm.139556/page-2#post-900311

Hoặc tham gia chủ đề này, để được những người có kiến thức sâu về chuyên môn giúp đỡ. OT cũng đang hỏi và hỏi ở chủ đề này:
https://www.giaiphapexcel.com/diendan/threads/các-câu-hỏi-về-mảng-trong-vba-array.46834/
 
Lần chỉnh sửa cuối:
Upvote 0
Nếu bạn đang học viết code thì:
- Luôn phải xóa kết quả cũ. Trong bài mà bạn cho link bạn thử như sau: nhấn GPE -> bạn có kết quả trong J12:K29 -> sau một thời gian xóa đi, nhập lại, sửa thì cột B trong sheet FILE GUI chỉ có 3 dòng dữ liệu B12:B14 -> nhấn GPE -> bạn vẫn có 18 kết quả trong J12:K29
Bạn không biết đâu là kết quả mới, đâu là kết quả cũ.
Tất nhiên người nhập liệu khi xóa chì còn 3 dòng dữ liệu B12:B14 thì anh ta nên tự xóa cả các kết quả trong J:K. Nhưng đấy là việc của anh ta. Anh ta có thể làm mà cũng có thể không. Người viết code hãy làm nhiệm vụ của bản thân mình và đừng bao giờ giả thiết là anh nhập liệu luôn ý thức được trách nhiệm của mình, luôn tỉnh táo, luôn không nhầm lẫn. Việc của người ta thì để người ta làm, việc của mình thì mình làm, đừng giả thiết là người khác sẽ chuẩn, sẽ có trách nhiệm.

- Người viết code không được phép giả thiết là dữ liệu luôn liên tục, không có dòng trống. Dùng xlDown? Nếu 'DANH SACH TONG'!B7 = rỗng thì sau khi chạy GPE sẽ thiếu kết quả. Tương tự khi vd. 'FILE GUI'!B15 = rỗng.
Dữ liệu liên tục thì tốt nhưng là người viết code thì không được phép mặc định như thế.

- Người viết code không được phép giả thiết là luôn có dữ liệu. Nếu cột B trong 'FILE GUI' hoặc/và 'DANH SACH TONG' không có dữ liệu thì dRng hoặc/và sRng sẽ có hàng triệu dòng. Lúc đó thì nhấn GPE rồi đi nhậu.

Tóm lại người viết code nên lường được những trường hợp dữ liệu, những sự cố có thể có và xử lý chúng. Càng lường được nhiều tình huống càng tốt. Trên đây tôi chỉ liệt kê ra 3 vấn đề mà người viết code bắt buộc phải xử lý.

Bạn tham khảo code ở dưới. Code dài hơn code ở link vì:
- gộp 2 trường hợp: chỉ lấy giá trị, và lấy giá trị và format.
- xóa kết quả cũ, xử lý trường hợp không có dữ liệu, và khi dữ liệu không liên tục.

Gán cho nút GPE macro test
Mã:
Private Sub sGPE(Optional ByVal format As Boolean = False)
Dim lastRow As Long, r1 As Long, r2 As Long, shSrc As Worksheet, shDest As Worksheet, csdl(), data(), result(), text As String
    Set shDest = Worksheets("FILE GUI")
    With shDest
'        xoa ket qua cu
        lastRow = .Cells(Rows.Count, "J").End(xlUp).Row
        If lastRow >= 12 Then
            With .Range("J12:K" & lastRow)
                .Clear
                .Borders.LineStyle = xlContinuous
            End With
        End If
        lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
'        neu khong co du lieu thi ket thuc cuoc choi, nguoc lai lay vao mang data
        If lastRow < 12 Then Exit Sub
        data = .Range("B12:B" & lastRow + 1).Value
'        mang ket qua
        If Not format Then ReDim result(1 To UBound(data) - 1, 1 To 2)
    End With
    Set shSrc = Worksheets("DANH SACH TONG")
    With shSrc
        lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
'        neu khong co du lieu thi ket thuc cuoc choi, nguoc lai lay vao mang csdl
        If lastRow < 4 Then Exit Sub
        csdl = .Range("B4:J" & lastRow).Value
    End With
    For r1 = 1 To UBound(data) - 1
        text = data(r1, 1)
        For r2 = 1 To UBound(csdl)
            If csdl(r2, 1) = text Then
                If format Then
                    shSrc.Cells(3 + r2, "I").Resize(, 2).Copy shDest.Cells(11 + r1, "J")
                Else
                    result(r1, 1) = csdl(r2, 8)
                    result(r1, 2) = csdl(r2, 9)
                End If
                Exit For
            End If
        Next r2
    Next r1
    If Not format Then shDest.Range("J12").Resize(UBound(result), 2).Value = result
End Sub

Sub test()
'    chi lay gia tri
    sGPE
'    lay gia tri va format
'    sGPE True
End Sub
Anh ơi em dò tìm dữ liệu lớn hơn 100 dữ liệu máy tính bị giật giật, trắng màng hình excel ( bị lag ) rồi tầm 5s sau mới ra giá trị tìm, anh có thể làm tăng tốc độ chạy hoặc cho code chạy bớt " lag " được ko ạ
vì sheet "danh sach tong" tầm hơn 4000 dòng, em do tìm tầm 120 dữ liệu bên sheet " file gui" thì nó bị vậy, ko biết có phải máy tính em cũ rồi nên nó bị vậy ko ạ
 
Lần chỉnh sửa cuối:
Upvote 0
Đính kèm tập tin giật giật ấy lên.
em có 1 chút việc nên giờ mới gửi cho anh mong anh thông cảm, anh coi qua file giúp em ! tình hình là máy tính cty em đời cũ, lọc tầm 200 mã nv là nó bị đứng tầm 7-10s, sau khi lọc xong máy tính chạy rất chậm kiểu bị " lag " , anh có thể chỉnh code cho chạy nhanh và bớt lag được ko ? cảm ơn anh !
 

File đính kèm

  • DANH SACH NV.xlsm
    130.1 KB · Đọc: 12
Upvote 0
em có 1 chút việc nên giờ mới gửi cho anh mong anh thông cảm, anh coi qua file giúp em ! tình hình là máy tính cty em đời cũ, lọc tầm 200 mã nv là nó bị đứng tầm 7-10s, sau khi lọc xong máy tính chạy rất chậm kiểu bị " lag " , anh có thể chỉnh code cho chạy nhanh và bớt lag được ko ? cảm ơn anh !
--------------------------------
 
Upvote 0
Đấy là tôi viết cho cấu trúc dữ liệu cũ

Bạn thử xem
Mã:
Private Sub sGPE(Optional ByVal format As Boolean = False)
Dim lastRow As Long, r1 As Long, r2 As Long, shSrc As Worksheet, shDest As Worksheet, csdl(), data(), result(), text As String, rng As Range
    Application.ScreenUpdating = False
   
    Set shDest = Worksheets("FILE GUI")
    With shDest
'        xoa ket qua cu
        lastRow = .Cells(Rows.Count, "J").End(xlUp).Row
        If lastRow >= 12 Then
            With .Range("J12:K" & lastRow)
                .Clear
                .Borders.LineStyle = xlContinuous
            End With
        End If
'        xac dinh dong cuoi co du lieu trong cot B (MHV) tai sheet FILE GUI
        lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
'        neu khong co du lieu thi ket thuc cuoc choi, nguoc lai lay vao mang data
        If lastRow < 12 Then Exit Sub
'        chi lay 1 cot MHV. Lay du ra 1 dong
        data = .Range("B12:B" & lastRow + 1).Value
'        mang ket qua - chi cho truong hop lay gia tri. Khi lay ca Format thi khong dung mang result
        If Not format Then ReDim result(1 To UBound(data) - 1, 1 To 2)
    End With
    Set shSrc = Worksheets("DANH SACH TONG")
    With shSrc
'        xac dinh dong cuoi co du lieu trong cot B (MHV) tai sheet DANH SACH TONG
        lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
'        neu khong co du lieu thi ket thuc cuoc choi, nguoc lai lay vao mang csdl
        If lastRow < 4 Then Exit Sub
'        lay tu cot MHV toi cot SDT BA
        csdl = .Range("B4:J" & lastRow).Value
    End With
'    duyet tung dong cua mang data (cot 1. Mang data cung chi co 1 cot) de lay MHV. Khong xet dong lay du vi the UBound(data) - 1
    For r1 = 1 To UBound(data) - 1
'        MHV hien hanh trong sheet FILE GUI
        text = data(r1, 1)
'        duyet tung dong cua mang csdl
        For r2 = 1 To UBound(csdl)
'            xet xem MHV hien hanh trong sheet DANH SACH TONG co y het MHV hien hanh trong sheet FILE GUI hay khong
            If csdl(r2, 1) = text Then
'                MHV hien hanh trong sheet DANH SACH TONG y het MHV hien hanh trong sheet FILE GUI
                If format Then
'                    Can lay ca Format, vay them 2 cell tren sheet DANH SACH TONG nam o cot I:J vao Range rng
'                    2 cell nay nam o dong 3 + r2 tren sheet DANH SACH TONG. Tai sao? Mang csdl duoc lay tu dong 4 tren sheet tro xuong.
'                    Dong 4 tren sheet tuong ung voi dong 1 trong mang csdl. Vi the dong r2 trong mang csdl tuong ung voi dong 3 + r2 tren sheet
                    If rng Is Nothing Then
'                        rng chua duoc thiet lap, vay lay 2 cell lam rng
                        Set rng = shSrc.Cells(3 + r2, "I").Resize(, 2)
                    Else
'                        rng da duoc thiet lap, vay them 2 cell vao Range rng
                        Set rng = Union(rng, shSrc.Cells(3 + r2, "I").Resize(, 2))
                    End If
                Else
'                    nhap SDT ME lay tu mang csdl tai dong hien hanh r2 cot 8 vao dong hien hanh r1 cot 1. Tai sao cot 8?
'                    Mang csdl duoc lay tu cot B (MHV) toi cot J (SDT CHA). Cot 1 trong mang csdl la MHV thi
'                    SDT ME phai nam o cot 8 cua mang csdl
                    result(r1, 1) = csdl(r2, 8)
'                    nhap SDT CHA lay tu mang csdl tai dong hien hanh r2 cot 9 vao dong hien hanh r1 cot 2. Tai sao cot 9?
'                    Mang csdl duoc lay tu cot B (MHV) toi cot J (SDT CHA). Cot 1 trong mang csdl la MHV thi
'                    SDT CHA phai nam o cot 9 cua mang csdl
                    result(r1, 2) = csdl(r2, 9)
                End If
'                Da tim thay MHV trong mang csdl va da xu ly nen thoat khoi vong lap duyet mang csdl
                Exit For
            End If
        Next r2
    Next r1
    If Not format Then
'        chi lay gia tri thi dap mang result vao sheet FILE GUI
        shDest.Range("J12").Resize(UBound(result), 2).Value = result
    Else
'        neu lay ca Format thi copy nhom cac Range "con" sang sheet FILE GUI, xuat phat tu cell J12
        rng.Copy shDest.Range("J12")
    End If
   
    Application.ScreenUpdating = True
End Sub

Sub test()
'    chi lay gia tri
'    sGPE
'    lay gia tri va format
    sGPE True
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Đấy là tôi viết cho cấu trúc dữ liệu cũ

Bạn thử xem
Mã:
           result(r1, 1) = csdl(r2, 8)
           result(r1, 2) = csdl(r2, 9)
Trong trường hợp em muốn lấy dữ liệu dạng Value ở 4 cột 1 lúc ( SĐT 1=> SĐT 4) sang file gửi thì sửa lại đoạn lệnh này thế nào anh?
 

File đính kèm

  • DANH SACH NV.xlsm
    144.8 KB · Đọc: 4
Upvote 0
Bạn sửa như sau xem đúng không ạ:
Mã:
If Not format Then ReDim result(1 To UBound(data) - 1, 1 To 2)
thành:
Mã:
If Not format Then ReDim result(1 To UBound(data) - 1, 1 To 4)
Sửa đoạn:
Mã:
                    shSrc.Cells(3 + r2, "I").Resize(, 2).Copy shDest.Cells(11 + r1, "J")
                Else
                    result(r1, 1) = csdl(r2, 8)
                    result(r1, 2) = csdl(r2, 9)
                End If
thành:

Mã:
                    shSrc.Cells(3 + r2, "I").Resize(, 4).Copy shDest.Cells(11 + r1, "J")
                Else
                    result(r1, 1) = csdl(r2, 9)
                    result(r1, 2) = csdl(r2, 10)
                    result(r1, 3) = csdl(r2, 11)
                    result(r1, 4) = csdl(r2, 12)
 
Upvote 0
Bạn sửa như sau xem đúng không ạ:
Mã:
If Not format Then ReDim result(1 To UBound(data) - 1, 1 To 2)
thành:
Mã:
If Not format Then ReDim result(1 To UBound(data) - 1, 1 To 4)
Sửa đoạn:
Mã:
                    shSrc.Cells(3 + r2, "I").Resize(, 2).Copy shDest.Cells(11 + r1, "J")
                Else
                    result(r1, 1) = csdl(r2, 8)
                    result(r1, 2) = csdl(r2, 9)
                End If
thành:

Mã:
                    shSrc.Cells(3 + r2, "I").Resize(, 4).Copy shDest.Cells(11 + r1, "J")
                Else
                    result(r1, 1) = csdl(r2, 9)
                    result(r1, 2) = csdl(r2, 10)
                    result(r1, 3) = csdl(r2, 11)    ' LỖI NẾU CHỈ LẤY VALUE
                    result(r1, 4) = csdl(r2, 12)
Trường hợp lấy cả Format thì ok, nhưng lấy Value thì nó vẫn không chạy và báo lỗi ở dòng mình tô đỏ? Bạn sửa lại giúp mình
 

File đính kèm

  • DANH SACH NV.xlsm
    129.7 KB · Đọc: 7
Upvote 0
Trường hợp lấy cả Format thì ok, nhưng lấy Value thì nó vẫn không chạy và báo lỗi ở dòng mình tô đỏ? Bạn sửa lại giúp mình
Híc mình xin lỗi, còn thiếu, bạn sửa tiếp:
Mã:
csdl = .Range("B4:J" & lastRow).Value
thành:
Mã:
csdl = .Range("B4:L" & lastRow).Value
Sửa:
Mã:
If Not format Then shDest.Range("J12").Resize(UBound(result), 6).Value = result
Thành:
Mã:
If Not format Then shDest.Range("J12").Resize(UBound(result), 4).Value = result

Mã:
Private Sub sGPE(Optional ByVal format As Boolean = False)
Dim lastRow As Long, r1 As Long, r2 As Long, shSrc As Worksheet, shDest As Worksheet, csdl(), data(), result(), text As String
    Set shDest = Worksheets("FILE GUI")
    With shDest
'        xoa ket qua cu
        lastRow = .Cells(Rows.Count, "J").End(xlUp).Row
        If lastRow >= 12 Then
            With .Range("J12:K" & lastRow)
                .Clear
                .Borders.LineStyle = xlContinuous
            End With
        End If
        lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
'        neu khong co du lieu thi ket thuc cuoc choi, nguoc lai lay vao mang data
        If lastRow < 12 Then Exit Sub
        data = .Range("B12:B" & lastRow + 1).Value
'        mang ket qua
        If Not format Then ReDim result(1 To UBound(data) - 1, 1 To 4)
    End With
    Set shSrc = Worksheets("DANH SACH TONG")
    With shSrc
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
'        neu khong co du lieu thi ket thuc cuoc choi, nguoc lai lay vao mang csdl
        If lastRow < 4 Then Exit Sub
        csdl = .Range("A4:L" & lastRow).Value
    End With
    For r1 = 1 To UBound(data) - 1
        text = data(r1, 1)
        For r2 = 1 To UBound(csdl)
            If csdl(r2, 1) = text Then
                If format Then
                    shSrc.Cells(3 + r2, "I").Resize(, 4).Copy shDest.Cells(11 + r1, "J")
                Else
                    result(r1, 1) = csdl(r2, 9)
                    result(r1, 2) = csdl(r2, 10)
                    result(r1, 3) = csdl(r2, 11)
                    result(r1, 4) = csdl(r2, 12)
                End If
                Exit For
            End If
        Next r2
    Next r1
    If Not format Then shDest.Range("J12").Resize(UBound(result), 4).Value = result
End Sub

Sub test()
'    chi lay gia tri
     sGPE
'    lay gia tri va format
'    sGPE True
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Híc mình xin lỗi, còn thiếu, bạn sửa tiếp:
Mã:
csdl = .Range("B4:J" & lastRow).Value
thành:
Mã:
csdl = .Range("B4:L" & lastRow).Value
Sửa:
Mã:
If Not format Then shDest.Range("J12").Resize(UBound(result), 6).Value = result
Thành:
Mã:
If Not format Then shDest.Range("J12").Resize(UBound(result), 4).Value = result

Mã:
Private Sub sGPE(Optional ByVal format As Boolean = False)
Dim lastRow As Long, r1 As Long, r2 As Long, shSrc As Worksheet, shDest As Worksheet, csdl(), data(), result(), text As String
    Set shDest = Worksheets("FILE GUI")
    With shDest
'        xoa ket qua cu
        lastRow = .Cells(Rows.Count, "J").End(xlUp).Row
        If lastRow >= 12 Then
            With .Range("J12:K" & lastRow)
                .Clear
                .Borders.LineStyle = xlContinuous
            End With
        End If
        lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
'        neu khong co du lieu thi ket thuc cuoc choi, nguoc lai lay vao mang data
        If lastRow < 12 Then Exit Sub
        data = .Range("B12:B" & lastRow + 1).Value
'        mang ket qua
        If Not format Then ReDim result(1 To UBound(data) - 1, 1 To 4)
    End With
    Set shSrc = Worksheets("DANH SACH TONG")
    With shSrc
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
'        neu khong co du lieu thi ket thuc cuoc choi, nguoc lai lay vao mang csdl
        If lastRow < 4 Then Exit Sub
        csdl = .Range("A4:L" & lastRow).Value
    End With
    For r1 = 1 To UBound(data) - 1
        text = data(r1, 1)
        For r2 = 1 To UBound(csdl)
            If csdl(r2, 1) = text Then
                If format Then
                    shSrc.Cells(3 + r2, "I").Resize(, 4).Copy shDest.Cells(11 + r1, "J")
                Else
                    result(r1, 1) = csdl(r2, 9)
                    result(r1, 2) = csdl(r2, 10)
                    result(r1, 3) = csdl(r2, 11)
                    result(r1, 4) = csdl(r2, 12)
                End If
                Exit For
            End If
        Next r2
    Next r1
    If Not format Then shDest.Range("J12").Resize(UBound(result), 4).Value = result
End Sub

Sub test()
'    chi lay gia tri
     sGPE
'    lay gia tri va format
'    sGPE True
End Sub
Vì sao lại viết Macro trên ở chế độ "riêng tư" Private?
Vì sao phải thêm Byval, nếu để Byref , nếu không để ?
Vậy OT?
 
Upvote 0
Vì sao lại viết Macro trên ở chế độ "riêng tư" Private?
Vì sao phải thêm Byval, nếu để Byref , nếu không để ?
Vậy OT?
Xin chào HeSanbi , phải chăng bạn muốn kiểm tra kiến thức của OT xem tới đâu?
Cảm ơn bạn đã quan tâm ạ :)
Private trong trường hợp này phạm vi nội bộ trong cùng module với sub gọi test để gọi,
nếu thêm Private cái này ở đầu thì khi tạo nút gán macro người dùng không thể nhìn thấy tên sub mà trước đó có Private .

Còn:
Vì sao phải thêm Byval, nếu để Byref , nếu không để ?
OT vừa mới tìm hiểu thêm ở đây:
https://www.giaiphapexcel.com/diendan/threads/bài-9-function-and-sub.130769/#post-821864
Theo OT hiểu,khai báo biến kiểu ByVal có nghĩa là các thay đổi của biến này chỉ có giá trị sử dụng trong riêng trong sub,kết thúc thủ tục biến sẽ trả về giá trị ban đầu.Khai báo biến kiểu ByRef thì khi kết thúc sub, nếu giá trị của biến bị thay đổi thì biến sẽ nhận giá trị mới này.
Trong trường hợp này OT thử:
Mã:
Private Sub sGPE(Optional format As Boolean = False)
Mã:
Private Sub sGPE(Optional ByRef format As Boolean = False)
Kết quả cũng không có gì khác nhau cả. o_O
Bạn có thể giải thích thêm được không ạ?
 
Upvote 0
Xin chào HeSanbi , phải chăng bạn muốn kiểm tra kiến thức của OT xem tới đâu?
Cảm ơn bạn đã quan tâm ạ :)
Private trong trường hợp này phạm vi nội bộ trong cùng module với sub gọi test để gọi,
nếu thêm Private cái này ở đầu thì khi tạo nút gán macro người dùng không thể nhìn thấy tên sub mà trước đó có Private .

Còn:

OT vừa mới tìm hiểu thêm ở đây:
https://www.giaiphapexcel.com/diendan/threads/bài-9-function-and-sub.130769/#post-821864
Theo OT hiểu,khai báo biến kiểu ByVal có nghĩa là các thay đổi của biến này chỉ có giá trị sử dụng trong riêng trong sub,kết thúc thủ tục biến sẽ trả về giá trị ban đầu.Khai báo biến kiểu ByRef thì khi kết thúc sub, nếu giá trị của biến bị thay đổi thì biến sẽ nhận giá trị mới này.
Trong trường hợp này OT thử:
Mã:
Private Sub sGPE(Optional format As Boolean = False)
Mã:
Private Sub sGPE(Optional ByRef format As Boolean = False)
Kết quả cũng không có gì khác nhau cả.
Bạn có thể giải thích thêm được không ạ?
Hỏi chơi không ngờ Thật

Private là không thể dùng được ở bất kì một VBProject nào khác cả ngoài nơi nó đứng. Trừ khi gọi một Public Hàm hoặc Public Sub
Nằm cùng với Private, và Public này lại được gọi ở một nơi khác
Byval khi gọi lại biến thì biến không đổi. Byref ngược lại. Không để gì thì mặc định là Byref
Hãy thử ví dụ bên dưới

PHP:
Sub LayTrongToiDiNay(optional Byref A$)
    A = "Nguyen Hoang Oanh Tho"
End Sub

Sub LayTrongToiDiNay2(optional Byval A$)
    A = "Nguyen Hoang Oanh Tho là ai"
End Sub

Sub ADauRoi()
    Dim AVeDay$, AVeDay2$
    AVeDay = "Nguyen Hoang Oanh Tho on GPE"
    LayTrongToiDiNay AVeDay
    'Call LayTrongToiDiNay(AVeDay)
    MsgBox AVeDay
    AVeDay2 = "Toi Van la Nguyen Hoang Oanh Tho"
    Call LayTrongToiDiNay2(AVeDay2)
    MsgBox AVeDay2

End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Web KT
Back
Top Bottom