Hoàn thiện code dò tìm 2 điều kiện và dò tim+ tính tổng? (1 người xem)

kydang1989 · 19/10/14

Em có sưu tầm và chế biến thành đoạn code phù hợp với dữ liệu của em
nhưng còn 2 vấn đề chưa giải quyết được:
- Tự động dò tìm 2 điều kiện (tương tự sử dụng index, match khi dùng hàm).
- Dò tìm kết hợp với tính tổng (có nghĩa là sau khi dò tìm sẽ tính tổng 2 cột ở bên sheet cần lấy giá trị)

Anh chị giúp em bổ sung thêm code để khi chạy thì nó ra 1 lần luôn...

Let'GâuGâu · 19/10/14

kydang1989 đã viết:
Em có sưu tầm và chế biến thành đoạn code phù hợp với dữ liệu của em
nhưng còn 2 vấn đề chưa giải quyết được:
- Tự động dò tìm 2 điều kiện (tương tự sử dụng index, match khi dùng hàm).
- Dò tìm kết hợp với tính tổng (có nghĩa là sau khi dò tìm sẽ tính tổng 2 cột ở bên sheet cần lấy giá trị)

Anh chị giúp em bổ sung thêm code để khi chạy thì nó ra 1 lần luôn...

Xem có đúng ko, đúng thì làm tiếp
thêm đoạn đoạn code này vào cuóicode của bạn để tìm hãng xe (cột H)

Mã:

For Each Cll In Sheets("price").[b10:b10000].SpecialCells(2)
        Set H_sou = Sheet6.[A4:e4].Find(Cll.Offset(, 1).Text, , , 1, 1)
        If Not H_sou Is Nothing Then
               Set V_Sou = Sheet6.[A4:A60000].Find(Cll.Offset(, 8).Text, , , xlWhole)
               If Not H_sou Is Nothing Then Cll.Offset(, 6) = V_Sou.Offset(, H_sou.Column-1)
        End If
    Next

==============
CTY bạn sản xuất wire hardness hả?

kydang1989 · 19/10/14

Let'GâuGâu đã viết:
Xem có đúng ko, đúng thì làm tiếp
thêm đoạn đoạn code này vào cuóicode của bạn để tìm hãng xe (cột H)

Mã:

For Each Cll In Sheets("price").[b10:b10000].SpecialCells(2) Set H_sou = Sheet6.[A4:e4].Find(Cll.Offset(, 1).Text, , , 1, 1) If Not H_sou Is Nothing Then Set V_Sou = Sheet6.[A4:A60000].Find(Cll.Offset(, 8).Text, , , xlWhole) If Not H_sou Is Nothing Then Cll.Offset(, 6) = V_Sou.Offset(, H_sou.Column-1) End If Next

==============
CTY bạn sản xuất wire hardness hả?

đúng rồi bạn
còn cột Q (tính tổng 2 giá trị) thì làm như thế nào vậy bạn ?

Let'GâuGâu · 20/10/14

kydang1989 đã viết:
đúng rồi bạn
còn cột Q (tính tổng 2 giá trị) thì làm như thế nào vậy bạn ?

bạn kiểm tra lại xem đúng không.
tôi nghĩ là bạn không cần nhiều vòng lặp For...Nẽxt nhiều lần như vậy

Mã:

Sub Copyprice()
    Dim Cll As Range, Sou As Range, kq()
    On Error Resume Next
    ReDim kq(Sheets("price").[A10:A10000].SpecialCells(2).Count, 1 To 26)
    
    For Each Cll In Sheets("price").[A10:A10000].SpecialCells(2)
       k = k + 1
        Set Sou = Sheets("NVL").[M10:M10000].Find(Cll.Text, , , xlWhole)
        If Not Sou Is Nothing Then
        kq(k, 1) = Sou.Offset(, -10)
        kq(k, 2) = Sou.Offset(, -3)
        kq(k, 3) = Sou.Offset(, -1)
        kq(k, 9) = Sou.Offset(, -11)
        kq(k, 11) = Sou.Offset(, 2)
         kq(k, 12) = Sou.Offset(, 3)
        kq(k, 13) = Sou.Offset(, 17)
         kq(k, 14) = Sou.Offset(, 18)
         kq(k, 20) = Sou.Offset(, 20)
        kq(k, 21) = Sou.Offset(, 24)
        kq(k, 22) = Sou.Offset(, 25)
       kq(k, 26) = Sou.Offset(, 29)
        
    End If
        Set Sou = Nothing
        Set Sou = Sheets("Nhancong").[G10:G10000].Find(Cll.Text, , , xlWhole)
        If Not Sou Is Nothing Then
            kq(k, 15) = Sou.Offset(, 10)
            kq(k, 17) = Sou.Offset(, 6)
            kq(k, 18) = Sou.Offset(, 9)
        End If
        Set Sou = Nothing
        Set Sou = Sheets("Nuocxk").[A2:A7].Find(kq(k, 9), , , xlWhole)
        If Not Sou Is Nothing Then kq(k, 6) = Sou.Offset(, 1)
        Set Sou = Nothing
        Set Sou = Sheets("Loaixe").[A2:A85].Find(kq(k, 2), , , xlWhole)
        If Not Sou Is Nothing Then kq(k, 7) = Sou.Offset(, 1)
        Set Sou = Nothing
        Set H_sou = Sheet6.[A4:e4].Find(kq(k, 2), , , 1, 1)
        If Not H_sou Is Nothing Then
               Set V_Sou = Sheet6.[A4:A60000].Find(kq(k, 9), , , xlWhole)
               If Not H_sou Is Nothing Then kq(k, 7) = V_Sou.Offset(, H_sou.Column - 1)
        End If
     Set Sou = Nothing
     Set Sou = Sheet4.[g2:G60000].Find(Cll.Text, , , xlWhole)
        If Not Sou Is Nothing Then kq(k, 16) = Sou.Offset(, 11) + Sou.Offset(, 14)
   
   Next
    Sheet1.[b10:AA60000].ClearContents
    Sheet1.[b10].Resize(k, 26).Value = kq
End Sub

kydang1989 · 20/10/14

Let'GâuGâu đã viết:

bạn kiểm tra lại xem đúng không.
tôi nghĩ là bạn không cần nhiều vòng lặp For...Nẽxt nhiều lần như vậy

Mã:

Sub Copyprice()
    Dim Cll As Range, Sou As Range, kq()
    On Error Resume Next
    ReDim kq(Sheets("price").[A10:A10000].SpecialCells(2).Count, 1 To 26)
    
    For Each Cll In Sheets("price").[A10:A10000].SpecialCells(2)
       k = k + 1
        Set Sou = Sheets("NVL").[M10:M10000].Find(Cll.Text, , , xlWhole)
        If Not Sou Is Nothing Then
        kq(k, 1) = Sou.Offset(, -10)
        kq(k, 2) = Sou.Offset(, -3)
        kq(k, 3) = Sou.Offset(, -1)
        kq(k, 9) = Sou.Offset(, -11)
        kq(k, 11) = Sou.Offset(, 2)
         kq(k, 12) = Sou.Offset(, 3)
        kq(k, 13) = Sou.Offset(, 17)
         kq(k, 14) = Sou.Offset(, 18)
         kq(k, 20) = Sou.Offset(, 20)
        kq(k, 21) = Sou.Offset(, 24)
        kq(k, 22) = Sou.Offset(, 25)
       kq(k, 26) = Sou.Offset(, 29)
        
    End If
        Set Sou = Nothing
        Set Sou = Sheets("Nhancong").[G10:G10000].Find(Cll.Text, , , xlWhole)
        If Not Sou Is Nothing Then
            kq(k, 15) = Sou.Offset(, 10)
            kq(k, 17) = Sou.Offset(, 6)
            kq(k, 18) = Sou.Offset(, 9)
        End If
        Set Sou = Nothing
        Set Sou = Sheets("Nuocxk").[A2:A7].Find(kq(k, 9), , , xlWhole)
        If Not Sou Is Nothing Then kq(k, 6) = Sou.Offset(, 1)
        Set Sou = Nothing
        Set Sou = Sheets("[COLOR=#ff0000][FONT=arial black]Loaixe[/FONT][/COLOR]").[A2:A85].Find(kq(k, [FONT=arial black][COLOR=#B22222]2[/COLOR])[/FONT], , , xlWhole)
        If Not Sou Is Nothing Then kq(k, [FONT=arial black][COLOR=#FF0000]7)[/COLOR][/FONT] = Sou.Offset(, 1)
        Set Sou = Nothing
        Set H_sou = Sheet6.[A4:e4].Find(kq(k, 2), , , 1, 1)
        If Not H_sou Is Nothing Then
               Set V_Sou = Sheet6.[A4:A60000].Find(kq(k, 9), , , xlWhole)
               If Not H_sou Is Nothing Then kq(k, 7) = V_Sou.Offset(, H_sou.Column - 1)
        End If
     Set Sou = Nothing
     Set Sou = Sheet4.[g2:G60000].Find(Cll.Text, , , xlWhole)
        If Not Sou Is Nothing Then kq(k, 16) = Sou.Offset(, 11) + Sou.Offset(, 14)
   
   Next
    Sheet1.[b10:AA60000].ClearContents
    Sheet1.[b10].Resize(k, 26).Value = kq
End Sub

không được bạn ơi
khi chạy code này nó bị lệch dòng
dòng 10 thì nó trống
dòng 11 là của dòng 10
dòng 12 là của dòng 11
dòng 13 là của dòng 12...
với lại "Loaixe" nó không chạy ra, chỉnh lại như thế nào vậy bạn ?

dhn46 · 20/10/14

Code để bạn đợi sửa, còn nếu bạn dùng công thức thì tham khảo công thức sau (Code cũng có thể dựa trên thuật toán của công thức mà làm).
Dữ liệu này giống YHV

H10

Mã:

=INDEX(hangxe!$B$5:$E$10,MATCH(J10,hangxe!$A$5:$A$10,0),MATCH(C10,hangxe!$B$4:$E$4,0))

Q10

Mã:

=INDEX(Nhancong!$R$10:$R$19,MATCH(A10,Nhancong!$G$10:$G$19,0),0)+INDEX(Nhancong!$U$10:$U$19,MATCH(A10,Nhancong!$G$10:$G$19,0),0)

Let'GâuGâu · 20/10/14

kydang1989 đã viết:
không được bạn ơi
khi chạy code này nó bị lệch dòng
dòng 10 thì nó trống
dòng 11 là của dòng 10
dòng 12 là của dòng 11
dòng 13 là của dòng 12...
với lại "Loaixe" nó không chạy ra, chỉnh lại như thế nào vậy bạn ?

hihihhi, lộn xộn tí
cột của mảng kết quả bằng thứ tự cột ở dòng 9
tôi tạm thời cho nó xuất ra ở dòng 15 để bạn so sánh với code cũ

Mã:

Sub Copyprice()
    Dim Cll As Range, Sou As Range, kq()
   ' On Error Resume Next
    ReDim kq(1 To Sheets("price").[A10:A10000].SpecialCells(2).Count, 1 To 26)
    
    For Each Cll In Sheets("price").[A10:A10000].SpecialCells(2)
       k = k + 1
        Set Sou = Sheets("NVL").[M10:M10000].Find(Cll.Text, , , xlWhole)
        If Not Sou Is Nothing Then
        kq(k, 1) = Sou.Offset(, -10)
        kq(k, 2) = Sou.Offset(, -3)
        kq(k, 3) = Sou.Offset(, -1)
        kq(k, 9) = Sou.Offset(, -11)
        kq(k, 11) = Sou.Offset(, 2)
         kq(k, 12) = Sou.Offset(, 3)
        kq(k, 13) = Sou.Offset(, 17)
         kq(k, 14) = Sou.Offset(, 18)
         kq(k, 20) = Sou.Offset(, 20)
        kq(k, 21) = Sou.Offset(, 24)
        kq(k, 22) = Sou.Offset(, 25)
       kq(k, 26) = Sou.Offset(, 29)
        
    End If
        Set Sou = Nothing
        Set Sou = Sheets("Nhancong").[G10:G10000].Find(Cll.Text, , , xlWhole)
        If Not Sou Is Nothing Then
            kq(k, 15) = Sou.Offset(, 10)
            kq(k, 17) = Sou.Offset(, 6)
            kq(k, 18) = Sou.Offset(, 9)
        End If
        Set Sou = Nothing
        Set Sou = Sheets("Nuocxk").[A2:A7].Find(kq(k, 9), , , xlWhole)
        If Not Sou Is Nothing Then kq(k, 6) = Sou.Offset(, 1)
        Set Sou = Nothing
        Set Sou = Sheets("Loaixe").[A1:A85].Find(kq(k, 1), , , xlWhole)
        
        If Not Sou Is Nothing Then kq(k, 8) = Sou.Offset(, 1)
        Set Sou = Nothing
        Set H_sou = Sheet6.[A4:e4].Find(kq(k, 2), , , 1, 1)
        If Not H_sou Is Nothing Then
               Set V_Sou = Sheet6.[A4:A60000].Find(kq(k, 9), , , xlWhole)
               If Not H_sou Is Nothing Then kq(k, 7) = V_Sou.Offset(, H_sou.Column - 1)
        End If
     Set Sou = Nothing
     Set Sou = Sheet4.[g2:G60000].Find(Cll.Text, , , xlWhole)
        If Not Sou Is Nothing Then kq(k, 16) = Sou.Offset(, 11) + Sou.Offset(, 14)
   kq(k, 19) = kq(k, 15) + kq(k, 16) + kq(k, 17) + kq(k, 18)
   kq(k, 23) = kq(k, 13) + kq(k, 14) + kq(k, 21) + kq(k, 22)
   kq(k, 24) = kq(k, 23) / 0.97 - kq(k, 23)
   kq(k, 25) = kq(k, 23) + kq(k, 24)
   
   Next
    Sheet1.[[COLOR=#ff0000]b15[/COLOR]:AA60000].ClearContents
    Sheet1.[[COLOR=#ff0000]b15[/COLOR]].Resize(k, 26).Value = kq
End Sub

làm xong rồi chỉnh lại [B10]

TrungChinhs · 20/10/14

Thử thêm cái này xem. Nếu bạn bố trí lại được cấu trúc các bảng giống nhau thì code sẽ ngắn và dễ viết hơn nhiều.

Mã:

Sub Copyprice2()
    On Error Resume Next
    
    With Sheets("NVL")
        For Each cls In Sheets("price").Range([a10], [a10000].End(3))
            Msp = 0
            Msp = Range(.[m10], .[m10000].End(3)).Find(cls, , , 1).Address
            If Msp > 0 Then
               cls(1, 2) = .Range(Msp)(1, -9)
               cls(1, 3) = .Range(Msp)(1, -2)
               cls(1, 4) = .Range(Msp)(1, 0)
               cls(1, 10) = .Range(Msp)(1, -10)
               cls(1, 12) = .Range(Msp)(1, 3)
               cls(1, 13) = .Range(Msp)(1, 4)
               cls(1, 14) = .Range(Msp)(1, 18)
               cls(1, 15) = .Range(Msp)(1, 19)
               cls(1, 21) = .Range(Msp)(1, 21)
               cls(1, 22) = .Range(Msp)(1, 25)
               cls(1, 23) = .Range(Msp)(1, 26)
               cls(1, 27) = .Range(Msp)(1, 30)
            End If
        Next
    End With


    With Sheets("NhanCong")
        For Each cls In Sheets("price").Range([a10], [a10000].End(3))
            Msp = 0
            Msp = Range(.[g10], .[g10000].End(3)).Find(cls, , , 1).Address
            If Msp > 0 Then
               cls(1, 16) = .Range(Msp)(1, 11)
               cls(1, 17) = .Range(Msp)(1, 12) + .Range(Msp)(1, 15)
               cls(1, 18) = .Range(Msp)(1, 7)
               cls(1, 19) = .Range(Msp)(1, 10)
            End If
        Next
    End With


    With Sheets("NuocXk")
        For Each cls In Sheets("price").Range([j10], [j10000].End(3))
            Xk = 0
            Xk = Range(.[a2], .[a10000].End(3)).Find(cls, , , 1).Address
            If Xk > 0 Then
               cls(1, -2) = .Range(Xk)(1, 2)
            End If
        Next
    End With
    
    With Sheets("HangXe")
        For Each cls In Sheets("price").Range([c10], [c10000].End(3))
            Y = 0: X = 0
            Y = Range(.[b4], .[e4]).Find(cls, , , 1).Column
            X = Range(.[a5], .[a10000].End(3)).Find(cls(1, 8), , , 1).Row
            If Y > 0 And X > 0 Then
                cls(1, 6) = .Cells(X, Y)
            End If
        Next
    End With
    
    With Sheets("LoaiXe")
        For Each cls In Sheets("price").Range([b10], [b10000].End(3))
            Lxe = 0
            Lxe = Range(.[a5], .[a10000].End(3)).Find(cls, , , 1).Address
            If Lxe > 0 Then
               cls(1, 8) = .Range(Lxe)(1, 2)
            End If
        Next
    End With
    
    For Each cls In Sheets("price").Range([a10], [a10000].End(3))
        cls(1, 20) = "=SUM(RC[-4]:RC[-1])"
        cls(1, 24) = "=SUM(RC[-10]:RC[-9],RC[-2]:RC[-1])"
        cls(1, 25) = "=RC[-1]/0.97-RC[-1]"
        cls(1, 26) = "=SUM(RC[-2]:RC[-1])"
    Next
    
End Sub

kydang1989 · 21/10/14

Let'GâuGâu đã viết:
hihihhi, lộn xộn tí
cột của mảng kết quả bằng thứ tự cột ở dòng 9
tôi tạm thời cho nó xuất ra ở dòng 15 để bạn so sánh với code cũ

làm xong rồi chỉnh lại [B10]

cám ơn các bạn đã tận tình chỉ dẫn mình, code chạy rất ok

cho mình hỏi thêm 1 vấn đề ngoài lề xíu
2 sheet NVL và Nhancong thực ra nó là 2 file nằm ở 2 thư mục khác nhau trên ổ đĩa (do mỗi người quản lý 1 file)
ví dụ file NVL nó nằm ở ổ E:/AnhA..., file Nhancong nằm ở E:/ChiB...(dùng chung ổ đĩa nhưng khác thư mục)
giả sử mình là người cần tổng hợp 2 file đó vào file Price, mình phải copy 2 file NVL và Nhancong để kế bên sheet trong file Price rồi mới chạy code trên.

Cho mình hỏi là có thể chèn thêm code nào vào và điều kiện là gì để khi chạy nó tự động hiện ra 1 cái bảng bắt mình chỉ nó đường dẫn đến 2 file NVL và Nhancong để nó tự động chạy (mình khỏi cần phải copy toàn bộ 2 file đó vào để kế bên file Price để chạy code trên...)

File Price, nuocxk, hangxe, loaixe là của mình (giả sử mình chỉ có 4 sheet này)
File NVL, Nhancong là của nhân viên khác

Let'GâuGâu · 21/10/14

kydang1989 đã viết:
cám ơn các bạn đã tận tình chỉ dẫn mình, code chạy rất ok

cho mình hỏi thêm 1 vấn đề ngoài lề xíu
2 sheet NVL và Nhancong thực ra nó là 2 file nằm ở 2 thư mục khác nhau trên ổ đĩa (do mỗi người quản lý 1 file)
ví dụ file NVL nó nằm ở ổ E:/AnhA..., file Nhancong nằm ở E:/ChiB...(dùng chung ổ đĩa nhưng khác thư mục)
giả sử mình là người cần tổng hợp 2 file đó vào file Price, mình phải copy 2 file NVL và Nhancong để kế bên sheet trong file Price rồi mới chạy code trên.

Cho mình hỏi là có thể chèn thêm code nào vào và điều kiện là gì để khi chạy nó tự động hiện ra 1 cái bảng bắt mình chỉ nó đường dẫn đến 2 file NVL và Nhancong để nó tự động chạy (mình khỏi cần phải copy toàn bộ 2 file đó vào để kế bên file Price để chạy code trên...)

File Price, nuocxk, hangxe, loaixe là của mình (giả sử mình chỉ có 4 sheet này)
File NVL, Nhancong là của nhân viên khác

dùng code mở file đó ra rồi cũng dùng phương thức find bình thường,xong đóng nó lại.
nhưng mà tên file, đường dẫn có cố định không hay thay đổi?

bạn up 2 file đó lên đi tôi làm cho

kydang1989 · 24/10/14

Let'GâuGâu đã viết:
dùng code mở file đó ra rồi cũng dùng phương thức find bình thường,xong đóng nó lại.
nhưng mà tên file, đường dẫn có cố định không hay thay đổi?

bạn up 2 file đó lên đi tôi làm cho

cảm ơn bạn, mình search trên diễn đàn và đã làm được rồi
nhưng còn 1 vấn đề muốn hỏi bạn, mong bạn chỉ giáo...

vẫn là về code dò tìm nhiều điều kiện: code này của bạn chạy rất ok, vấn đề là lại phát sinh thêm điều kiện thứ 3 nên không biết phải làm sao để chạy được nhiều điều kiện

Let'GâuGâu đã viết:
Xem có đúng ko, đúng thì làm tiếp
thêm đoạn đoạn code này vào cuóicode của bạn để tìm hãng xe (cột H)

Mã:

For Each Cll In Sheets("price").[b10:b10000].SpecialCells(2) Set H_sou = Sheet6.[A4:e4].Find(Cll.Offset(, 1).Text, , , 1, 1) If Not H_sou Is Nothing Then Set V_Sou = Sheet6.[A4:A60000].Find(Cll.Offset(, 8).Text, , , xlWhole) If Not H_sou Is Nothing Then Cll.Offset(, 6) = V_Sou.Offset(, H_sou.Column-1) End If Next

có nghĩa là dữ liệu dò tìm bây giờ là 3 điều kiện chứ ko phải 2 điều kiện như code phía trên. mong bạn giúp mình chèn thêm code để chạy được nhiều điều kiện ...

Let'GâuGâu · 25/10/14

kydang1989 đã viết:
cảm ơn bạn, mình search trên diễn đàn và đã làm được rồi
nhưng còn 1 vấn đề muốn hỏi bạn, mong bạn chỉ giáo...

vẫn là về code dò tìm nhiều điều kiện: code này của bạn chạy rất ok, vấn đề là lại phát sinh thêm điều kiện thứ 3 nên không biết phải làm sao để chạy được nhiều điều kiện

có nghĩa là dữ liệu dò tìm bây giờ là 3 điều kiện chứ ko phải 2 điều kiện như code phía trên. mong bạn giúp mình chèn thêm code để chạy được nhiều điều kiện ...

với nhiều điều kiện tôi nghĩ là nên dùng advanced filter sẻ hiệu quả hơn
============
tôi có thầy bạn mở một topic về vấn đề này. nhưng nhìn bạn trộn cell (merge) thấy ngán quá nên ko dám nhẩy vô..............hhihihihi

kydang1989 · 25/10/14

Let'GâuGâu đã viết:
với nhiều điều kiện tôi nghĩ là nên dùng advanced filter sẻ hiệu quả hơn
============
tôi có thầy bạn mở một topic về vấn đề này. nhưng nhìn bạn trộn cell (merge) thấy ngán quá nên ko dám nhẩy vô..............hhihihihi

advanced filter mình ko làm dc giống như form mẫu
cái form mẫu đó là sếp bắt làm giống như sếp, có thể bổ sung thêm dòng hoặc cột phụ trong sheet đó để hỗ trợ việc chạy code. chạy code xong rồi xóa mấy dòng, cột phụ cũng được.
trong file mới này cột A trộn nhưng mình có bổ sung thêm cột F và cột G hỗ trợ việc chạy code. CỘt G mình có tách ra để dễ chạy code, định chạy code xong sẽ xóa cột F, G , lần sau chạy thì copy bỏ vô lại.
mình chạy được 1 tháng, còn 2 tháng vẫn chưa chạy được...

Let'GâuGâu · 25/10/14

kydang1989 đã viết:
advanced filter mình ko làm dc giống như form mẫu
cái form mẫu đó là sếp bắt làm giống như sếp, có thể bổ sung thêm dòng hoặc cột phụ trong sheet đó để hỗ trợ việc chạy code. chạy code xong rồi xóa mấy dòng, cột phụ cũng được.
trong file mới này cột A trộn nhưng mình có bổ sung thêm cột F và cột G hỗ trợ việc chạy code. CỘt G mình có tách ra để dễ chạy code, định chạy code xong sẽ xóa cột F, G , lần sau chạy thì copy bỏ vô lại.
mình chạy được 1 tháng, còn 2 tháng vẫn chưa chạy được...

sử dụng sự kiện work sheet change
khi bạn nhập ngày vào C1:E1 code sẻ chạy
chép đoạn code sau đây vào sheet4

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cll As Range, H_Sou As Range, St As String, KQ(), ER As Long

If Not Intersect(Target, [c1:e1]) Is Nothing Then
    ER = Sheet4.[B60000].End(3).Row
   ReDim KQ(1 To ER, 1 To 1)
   
For Each Cll In Sheets("XuongA").[a2].Resize(ER)
If Not IsEmpty(Cll) Then
St = Cll & "::LINE " & Cll
        Set H_Sou = Sheet2.[H10:GO10].Find(St, , , 1, 1)
        If Not H_Sou Is Nothing Then
            If H_Sou.Offset(-2) = Target.Value Then
            f_Address = H_Sou.Address
                k = k + 1: KQ(k, 1) = H_Sou.Offset(13)
                k = k + 1: KQ(k, 1) = H_Sou.Offset(16)
                k = k + 1: KQ(k, 1) = KQ(k - 2, 1) - KQ(k - 1, 1)
            Else
                Do
                    Set H_Sou = Sheet2.[H10:GO10].FindNext(H_Sou)
                    If Not H_Sou Is Nothing Then
                    
                        If H_Sou.Offset(-2) = Target.Value Then
                            k = k + 1: KQ(k, 1) = H_Sou.Offset(13)
                            k = k + 1: KQ(k, 1) = H_Sou.Offset(16)
                            k = k + 1: KQ(k, 1) = KQ(k - 2, 1) - KQ(k - 1, 1)
                            Exit Do
                        End If
                    End If
                    Loop While Not H_Sou Is Nothing And H_Sou.Address <> f_Address
            End If
   End If
End If
Next
 Target.Offset(1).Resize(k).Value = KQ
 End If
End Sub

kydang1989 · 25/10/14

Let'GâuGâu đã viết:
code này chạy dựa vào cột cuối cùng mà nó xác định được ở dòng số 1
vì vậy để chạy code, bạn xoá D1 và E1 đi để chạy tháng 7
xong nhập ngày vào D1 rồi chạy code
nhập vào É rồi chạy code

cảm ơn Let'GauGau về code này. hjhj

kydang1989 · 25/10/14

Let'GâuGâu đã viết:

sử dụng sự kiện work sheet change
khi bạn nhập ngày vào C1:E1 code sẻ chạy
chép đoạn code sau đây vào sheet4

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cll As Range, H_Sou As Range, St As String, KQ(), ER As Long

If Not Intersect(Target, [c1:e1]) Is Nothing Then
    ER = Sheet4.[B60000].End(3).Row
   ReDim KQ(1 To ER, 1 To 1)
   
For Each Cll In Sheets("XuongA").[a2].Resize(ER)
If Not IsEmpty(Cll) Then
St = Cll & "::LINE " & Cll
        Set H_Sou = Sheet2.[H10:GO10].Find(St, , , 1, 1)
        If Not H_Sou Is Nothing Then
            If H_Sou.Offset(-2) = Target.Value Then
            f_Address = H_Sou.Address
                k = k + 1: KQ(k, 1) = H_Sou.Offset(13)
                k = k + 1: KQ(k, 1) = H_Sou.Offset(16)
                k = k + 1: KQ(k, 1) = KQ(k - 2, 1) - KQ(k - 1, 1)
            Else
                Do
                    Set H_Sou = Sheet2.[H10:GO10].FindNext(H_Sou)
                    If Not H_Sou Is Nothing Then
                    
                        If H_Sou.Offset(-2) = Target.Value Then
                            k = k + 1: KQ(k, 1) = H_Sou.Offset(13)
                            k = k + 1: KQ(k, 1) = H_Sou.Offset(16)
                            k = k + 1: KQ(k, 1) = KQ(k - 2, 1) - KQ(k - 1, 1)
                            Exit Do
                        End If
                    End If
                    Loop While Not H_Sou Is Nothing And H_Sou.Address <> f_Address
            End If
   End If
End If
Next
 Target.Offset(1).Resize(k).Value = KQ
 End If
End Sub

cách chép code vào sheet4 như thế nào vậy bạn, mình chưa biết cách chép luôn vào sheet. (cách thường dùng là chèn modules xong rồi gán marco)

Let'GâuGâu · 25/10/14

kydang1989 đã viết:
cách chép code vào sheet4 như thế nào vậy bạn, mình chưa biết cách chép luôn vào sheet. (cách thường dùng là chèn modules xong rồi gán marco)

trong cửa sổ vba, phía trên mấy cái module bạn thấy có mấy cái sheet đó, nhấp vô đó rồi chép toàn bô code vào cửa sổ bên tay phải

kydang1989 · 25/10/14

Let'GâuGâu đã viết:
trong cửa sổ vba, phía trên mấy cái module bạn thấy có mấy cái sheet đó, nhấp vô đó rồi chép toàn bô code vào cửa sổ bên tay phải

mình chép vào sheet4 rồi giờ không biết chạy như thế nào, mình tưởng chỉ cần chép code vào sheet4 là chạy được nên xóa cái code củ ở modules, bạn cho mình xin lại cái code củ với
(có phải là phải có code củ + worksheet change mới chạy được ?)

Let'GâuGâu · 25/10/14

kydang1989 đã viết:
mình chép vào sheet4 rồi giờ không biết chạy như thế nào, mình tưởng chỉ cần chép code vào sheet4 là chạy được nên xóa cái code củ ở modules, bạn cho mình xin lại cái code củ với
(có phải là phải có code củ + worksheet change mới chạy được ?)

Mã:

If Not Intersect(Target, [c1:e1]) Is Nothing Then

đoạn code này có nghĩa là, khi bạn có sự thay đổi trong vùng C1:E1
thì code sẻ tự chạy
bạn tử nhấp chuột vào cell D1 rồi enter xem

kydang1989 · 25/10/14

Let'GâuGâu đã viết:
Mã:

If Not Intersect(Target, [c1:e1]) Is Nothing Then

đoạn code này có nghĩa là, khi bạn có sự thay đổi trong vùng C1:E1
thì code sẻ tự chạy
bạn tử nhấp chuột vào cell D1 rồi enter xem

mình làm vậy nó bị lỗi, nó tô màu chữ "Target" rồi hiện bảng: Compile Eror . Invalid outside Procedure ?

Let'GâuGâu · 25/10/14

kydang1989 đã viết:
mình làm vậy nó bị lỗi, nó tô màu chữ "Target" rồi hiện bảng: Compile Eror . Invalid outside Procedure ?

xem thử con ko được thua.............hihihihih ,,,,,,,

,,xài như cũ vậy........heheheheh

kydang1989 · 25/10/14

mình làm được rồi, phải nhập "2014/07" chứ không phải "07/2014",hjhj. nếu nhập "07/2014" nó bị treo máy luôn

Let'GâuGâu · 25/10/14

kydang1989 đã viết:
mình làm được rồi, phải nhập "2014/07" chứ không phải "07/2014",hjhj. nếu nhập "07/2014" nó bị treo máy luôn

như vậy phải viết thêm lệnh if để ngăn ngừa nhập mấy số tâm bậy
bạn thử viết xem

Hoàn thiện code dò tìm 2 điều kiện và dò tim+ tính tổng? (1 người xem)

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

Thành viên chính thức

File đính kèm

Thành viên mới

Thành viên chính thức

Thành viên mới

Thành viên chính thức

Hướng tới tương lai

Thành viên mới

Thành viên tích cực

Thành viên chính thức

Thành viên mới

Thành viên chính thức

File đính kèm

Thành viên mới

Thành viên chính thức

Thành viên mới

Thành viên chính thức

Thành viên chính thức

Thành viên mới

Thành viên chính thức

Thành viên mới

Thành viên chính thức

Thành viên mới

File đính kèm

Thành viên chính thức

Thành viên mới

Thời gian đếm ngược.