Đổi Ngày (dd/mm/yyyy) Thành Ngày - Tháng - Năm - Tuần - Thứ!! (2 người xem)

  • Thread starter Thread starter LamNA
  • 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)
batman1 đã viết:
Code đòi hỏi cột M phải là ngày tháng chứ không phải trông giống ngày tháng. Hiện cột D không chứa ngày tháng theo đúng triết lý của Excel. D chỉ chứa chuỗi thôi. Tự bạn nhập lại hoặc nhờ ai đó sửa lại. Tôi không muốn mất công chỉ vì ai đó cẩu thả.

Tôi viết lại code vì thấy bạn phục vụ tới 600000 dòng, và có chuyện "đổ" dữ liệu vào sheet. Nếu đổ mỗi lần hàng ngàn, chục ngàn dòng thì code cũ chạy lâu.
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, tmp
Dim result(), ba(), change As Range, songayma As String, so_ngay_ma As Object
    If Dic Is Nothing Then Vlookup_DATA_SP
   
    Application.EnableEvents = False
    Application.ScreenUpdating = False
   
    Set change = Intersect(Range("D851:D600000"), Target)
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ReDim Preserve result(1 To UBound(result), 1 To 3)
   
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) Then
                tmp = result(i, 1)
                If Dic.exists(tmp) Then
                    result(i, 1) = aResult(Dic.Item(tmp), 3) 'NGANH HANG
                    result(i, 2) = aResult(Dic.Item(tmp), 5) 'LOAI HANG
                    result(i, 3) = aResult(Dic.Item(tmp), 4) 'HANG
                End If
            End If
        Next i
        change.Offset(0, 36).Resize(, 3).Value = result
    End If
'    ngay thang
    Set change = Intersect(Target, Range("M851:M600000")) ' Ngay Thang Nam, Tuan
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ReDim Preserve result(1 To UBound(result), 1 To 5)
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) Then
                result(i, 2) = WorksheetFunction.Text(result(i, 1), "[$-42A]ddd")
                result(i, 3) = Format(result(i, 1), "d")
                result(i, 4) = Format(result(i, 1), "m")
                result(i, 5) = Format(result(i, 1), "yyyy")
                result(i, 1) = Format(result(i, 1), "ww")
            End If
        Next i
        change.Offset(0, 31).Resize(, 5).Value = result
    End If
'   Phan Khuc Gia va cot BA
    Set change = Intersect(Target, Range("AC851:AC600000"))
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ba = result
        For i = 1 To UBound(result) - 1
            ba(i, 1) = result(i, 1) / 101
            If Len(result(i, 1)) Then
                Select Case result(i, 1) / 10 ^ 6
                    Case Is <= 1: result(i, 1) = "<1M"
                    Case Is <= 2: result(i, 1) = "1M-2M"
                    Case Is <= 4: result(i, 1) = "2M-4M"
                    Case Is <= 6: result(i, 1) = "4M-6M"
                    Case Is <= 8: result(i, 1) = "6M-8M"
                    Case Is <= 10: result(i, 1) = "8M-10M"
                    Case Is <= 12: result(i, 1) = "10M-12M"
                    Case Is <= 14: result(i, 1) = "12M-14M"
                    Case Is <= 16: result(i, 1) = "14M-16M"
                    Case Is <= 18: result(i, 1) = "16M-18M"
                    Case Is <= 20: result(i, 1) = "18M-20M"
                    Case Else: result(i, 1) = "Tren 20M"
               End Select
            End If
        Next i
'        Phan Khuc Gia
        change.Offset(0, 14).Value = result
'        cot BA
        Range("BA" & change.Row).Resize(UBound(ba) - 1).Value = ba
    End If
'    cot AY
    Set change = Intersect(Target, Range("M851:M600000, P851:P600000"))
    If Not change Is Nothing Then
        Set so_ngay_ma = CreateObject("Scripting.Dictionary")
        result = Range(Cells(change.Row, "M"), Cells(change.Row + change.Rows.Count - 1, "P"))
        For i = 1 To UBound(result)
            songayma = result(i, 1) & "-" & result(i, 4)
            If so_ngay_ma.exists(songayma) Then
                result(i, 1) = 0
            Else
                result(i, 1) = 1
                so_ngay_ma.Add songayma, ""
            End If
        Next i
        Cells(change.Row, "AY").Resize(UBound(result)).Value = result
        Set so_ngay_ma = Nothing
    End If
'    cot AZ
    Set change = Intersect(Target, Range("C851:C600000, M851:M600000"))
    If Not change Is Nothing Then
        Set so_ngay_ma = CreateObject("Scripting.Dictionary")
        result = Range(Cells(change.Row, "C"), Cells(change.Row + change.Rows.Count - 1, "M"))
        For i = 1 To UBound(result)
            songayma = result(i, 1) & "-" & result(i, 11)
            If so_ngay_ma.exists(songayma) Then
                result(i, 1) = 0
            Else
                result(i, 1) = 1
                so_ngay_ma.Add songayma, ""
            End If
        Next i
        Cells(change.Row, "AZ").Resize(UBound(result)).Value = result
        Set so_ngay_ma = Nothing
    End If
   
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Cần gì thêm thì nên mở chủ đề mới nhé.
Nhấp chuột vào đây để mở rộng...

Em cám ơn anh nhều, nó tính hơi lâu bù lại file nhẹ, cái nào cũng có ưu nhược điểm.
Dạ nếu có vấn đề cần hỗ trợ em sẽ tạo chủ đề mới
Một lần nữa em rất cám ơn anh đã hỗ trơ
Chúc anh buổi tối vui vẻ
 
LamNA đã viết:
Em cám ơn anh nhều, nó tính hơi lâu bù lại file nhẹ, cái nào cũng có ưu nhược điểm.
Nhấp chuột vào đây để mở rộng...
Ý bạn muốn nói là công thức tuy nặng nhưng tính nhanh hơn?

Máy của tôi 17 năm tuổi, đĩa cứng 38GB (C có 10GB), 2 GHz, RAM 1GB nếu đổ xuống sheet 600 000 dòng dữ liệu từ A đến AM thì mất khoảng 240 giây. Nếu máy của bạn mới thì có lẽ chỉ khoảng 30 đến 60 giây.
Với công thức thì chưa bàn tới nặng hay nhẹ tập tin mà nếu bạn đổ 600 000 dòng dữ liệu xuống sheet thì các công thức kia cũng khó mà tính toán nhanh hơn.
 
Khi viết lại đoạn code đầu của bạn tôi đã bỏ xót việc xóa dữ liệu của cột đầu ở mảng kết quả
Hãy sửa
Mã: 
If Dic.exists(tmp) Then
                    result(i, 1) = aResult(Dic.Item(tmp), 3) 'NGANH HANG
                    result(i, 2) = aResult(Dic.Item(tmp), 5) 'LOAI HANG
                    result(i, 3) = aResult(Dic.Item(tmp), 4) 'HANG
End If
thành
Mã: 
If Dic.exists(tmp) Then
    result(i, 1) = aResult(Dic.Item(tmp), 3) 'NGANH HANG
    result(i, 2) = aResult(Dic.Item(tmp), 5) 'LOAI HANG
    result(i, 3) = aResult(Dic.Item(tmp), 4) 'HANG
Else
    result(i, 1) = Empty
End If
Tức thêm 2 dòng
Mã: 
Else
    result(i, 1) = Empty
----------------
Bạn cũng có thể dùng phiên bản mới dùng ít bộ nhớ hơn - mảng làm việc nhỏ hơn
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, tmp
Dim result(), cot2(), ba(), change As Range, songayma As String, so_ngay_ma As Object, t
    t = Timer
    If Dic Is Nothing Then Vlookup_DATA_SP
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    Set change = Intersect(Range("D851:D600000"), Target)
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ReDim Preserve result(1 To UBound(result), 1 To 3)
    
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) Then
                tmp = result(i, 1)
                If Dic.exists(tmp) Then
                    result(i, 1) = aResult(Dic.Item(tmp), 3) 'NGANH HANG
                    result(i, 2) = aResult(Dic.Item(tmp), 5) 'LOAI HANG
                    result(i, 3) = aResult(Dic.Item(tmp), 4) 'HANG
                Else
                    result(i, 1) = Empty
                End If
            End If
        Next i
        change.Offset(0, 36).Resize(, 3).Value = result
    End If
'    ngay thang
    Set change = Intersect(Target, Range("M851:M600000")) ' Ngay Thang Nam, Tuan
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ReDim Preserve result(1 To UBound(result), 1 To 5)
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) Then
                result(i, 2) = WorksheetFunction.Text(result(i, 1), "[$-42A]ddd")
                result(i, 3) = Format(result(i, 1), "d")
                result(i, 4) = Format(result(i, 1), "m")
                result(i, 5) = Format(result(i, 1), "yyyy")
                result(i, 1) = Format(result(i, 1), "ww")
            End If
        Next i
        change.Offset(0, 31).Resize(, 5).Value = result
    End If
'   Phan Khuc Gia va cot BA
    Set change = Intersect(Target, Range("AC851:AC600000"))
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ba = result
        For i = 1 To UBound(result) - 1
            ba(i, 1) = result(i, 1) / 101
            If Len(result(i, 1)) Then
                Select Case result(i, 1) / 10 ^ 6
                    Case Is <= 1: result(i, 1) = "<1M"
                    Case Is <= 2: result(i, 1) = "1M-2M"
                    Case Is <= 4: result(i, 1) = "2M-4M"
                    Case Is <= 6: result(i, 1) = "4M-6M"
                    Case Is <= 8: result(i, 1) = "6M-8M"
                    Case Is <= 10: result(i, 1) = "8M-10M"
                    Case Is <= 12: result(i, 1) = "10M-12M"
                    Case Is <= 14: result(i, 1) = "12M-14M"
                    Case Is <= 16: result(i, 1) = "14M-16M"
                    Case Is <= 18: result(i, 1) = "16M-18M"
                    Case Is <= 20: result(i, 1) = "18M-20M"
                    Case Else: result(i, 1) = "Tren 20M"
               End Select
            End If
        Next i
'        Phan Khuc Gia
        change.Offset(0, 14).Value = result
'        cot BA
        Range("BA" & change.Row).Resize(UBound(ba) - 1).Value = ba
    End If
'    cot AY
    Set change = Intersect(Target, Range("M851:M600000, P851:P600000"))
    If Not change Is Nothing Then
        Set so_ngay_ma = CreateObject("Scripting.Dictionary")
        result = Range("M" & change.Row).Resize(change.Rows.Count + 1).Value
        cot2 = Range("M" & change.Row).Offset(0, 3).Resize(change.Rows.Count + 1).Value
        For i = 1 To UBound(result) - 1
            songayma = result(i, 1) & "-" & cot2(i, 1)
            If so_ngay_ma.exists(songayma) Then
                result(i, 1) = 0
            Else
                result(i, 1) = 1
                so_ngay_ma.Add songayma, ""
            End If
        Next i
        Cells(change.Row, "AY").Resize(UBound(result) - 1).Value = result
        Set so_ngay_ma = Nothing
    End If
'    cot AZ
    Set change = Intersect(Target, Range("C851:C600000, M851:M600000"))
    If Not change Is Nothing Then
        Set so_ngay_ma = CreateObject("Scripting.Dictionary")
        result = Range("C" & change.Row).Resize(change.Rows.Count + 1).Value
        cot2 = Range("C" & change.Row).Offset(0, 10).Resize(change.Rows.Count + 1).Value
        For i = 1 To UBound(result) - 1
            songayma = result(i, 1) & "-" & cot2(i, 1)
            If so_ngay_ma.exists(songayma) Then
                result(i, 1) = 0
            Else
                result(i, 1) = 1
                so_ngay_ma.Add songayma, ""
            End If
        Next i
        Cells(change.Row, "AZ").Resize(UBound(result) - 1).Value = result
        Set so_ngay_ma = Nothing
    End If
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    Debug.Print Timer - t
End Sub
 
batman1 đã viết:
Khi viết lại đoạn code đầu của bạn tôi đã bỏ xót việc xóa dữ liệu của cột đầu ở mảng kết quả
Hãy sửa
Mã: 
If Dic.exists(tmp) Then
                    result(i, 1) = aResult(Dic.Item(tmp), 3) 'NGANH HANG
                    result(i, 2) = aResult(Dic.Item(tmp), 5) 'LOAI HANG
                    result(i, 3) = aResult(Dic.Item(tmp), 4) 'HANG
End If
thành
Mã: 
If Dic.exists(tmp) Then
    result(i, 1) = aResult(Dic.Item(tmp), 3) 'NGANH HANG
    result(i, 2) = aResult(Dic.Item(tmp), 5) 'LOAI HANG
    result(i, 3) = aResult(Dic.Item(tmp), 4) 'HANG
Else
    result(i, 1) = Empty
End If
Tức thêm 2 dòng
Mã: 
Else
    result(i, 1) = Empty
----------------
Bạn cũng có thể dùng phiên bản mới dùng ít bộ nhớ hơn - mảng làm việc nhỏ hơn
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, tmp
Dim result(), cot2(), ba(), change As Range, songayma As String, so_ngay_ma As Object, t
    t = Timer
    If Dic Is Nothing Then Vlookup_DATA_SP
  
    Application.EnableEvents = False
    Application.ScreenUpdating = False
  
    Set change = Intersect(Range("D851:D600000"), Target)
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ReDim Preserve result(1 To UBound(result), 1 To 3)
  
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) Then
                tmp = result(i, 1)
                If Dic.exists(tmp) Then
                    result(i, 1) = aResult(Dic.Item(tmp), 3) 'NGANH HANG
                    result(i, 2) = aResult(Dic.Item(tmp), 5) 'LOAI HANG
                    result(i, 3) = aResult(Dic.Item(tmp), 4) 'HANG
                Else
                    result(i, 1) = Empty
                End If
            End If
        Next i
        change.Offset(0, 36).Resize(, 3).Value = result
    End If
'    ngay thang
    Set change = Intersect(Target, Range("M851:M600000")) ' Ngay Thang Nam, Tuan
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ReDim Preserve result(1 To UBound(result), 1 To 5)
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) Then
                result(i, 2) = WorksheetFunction.Text(result(i, 1), "[$-42A]ddd")
                result(i, 3) = Format(result(i, 1), "d")
                result(i, 4) = Format(result(i, 1), "m")
                result(i, 5) = Format(result(i, 1), "yyyy")
                result(i, 1) = Format(result(i, 1), "ww")
            End If
        Next i
        change.Offset(0, 31).Resize(, 5).Value = result
    End If
'   Phan Khuc Gia va cot BA
    Set change = Intersect(Target, Range("AC851:AC600000"))
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ba = result
        For i = 1 To UBound(result) - 1
            ba(i, 1) = result(i, 1) / 101
            If Len(result(i, 1)) Then
                Select Case result(i, 1) / 10 ^ 6
                    Case Is <= 1: result(i, 1) = "<1M"
                    Case Is <= 2: result(i, 1) = "1M-2M"
                    Case Is <= 4: result(i, 1) = "2M-4M"
                    Case Is <= 6: result(i, 1) = "4M-6M"
                    Case Is <= 8: result(i, 1) = "6M-8M"
                    Case Is <= 10: result(i, 1) = "8M-10M"
                    Case Is <= 12: result(i, 1) = "10M-12M"
                    Case Is <= 14: result(i, 1) = "12M-14M"
                    Case Is <= 16: result(i, 1) = "14M-16M"
                    Case Is <= 18: result(i, 1) = "16M-18M"
                    Case Is <= 20: result(i, 1) = "18M-20M"
                    Case Else: result(i, 1) = "Tren 20M"
               End Select
            End If
        Next i
'        Phan Khuc Gia
        change.Offset(0, 14).Value = result
'        cot BA
        Range("BA" & change.Row).Resize(UBound(ba) - 1).Value = ba
    End If
'    cot AY
    Set change = Intersect(Target, Range("M851:M600000, P851:P600000"))
    If Not change Is Nothing Then
        Set so_ngay_ma = CreateObject("Scripting.Dictionary")
        result = Range("M" & change.Row).Resize(change.Rows.Count + 1).Value
        cot2 = Range("M" & change.Row).Offset(0, 3).Resize(change.Rows.Count + 1).Value
        For i = 1 To UBound(result) - 1
            songayma = result(i, 1) & "-" & cot2(i, 1)
            If so_ngay_ma.exists(songayma) Then
                result(i, 1) = 0
            Else
                result(i, 1) = 1
                so_ngay_ma.Add songayma, ""
            End If
        Next i
        Cells(change.Row, "AY").Resize(UBound(result) - 1).Value = result
        Set so_ngay_ma = Nothing
    End If
'    cot AZ
    Set change = Intersect(Target, Range("C851:C600000, M851:M600000"))
    If Not change Is Nothing Then
        Set so_ngay_ma = CreateObject("Scripting.Dictionary")
        result = Range("C" & change.Row).Resize(change.Rows.Count + 1).Value
        cot2 = Range("C" & change.Row).Offset(0, 10).Resize(change.Rows.Count + 1).Value
        For i = 1 To UBound(result) - 1
            songayma = result(i, 1) & "-" & cot2(i, 1)
            If so_ngay_ma.exists(songayma) Then
                result(i, 1) = 0
            Else
                result(i, 1) = 1
                so_ngay_ma.Add songayma, ""
            End If
        Next i
        Cells(change.Row, "AZ").Resize(UBound(result) - 1).Value = result
        Set so_ngay_ma = Nothing
    End If
  
    Application.EnableEvents = True
    Application.ScreenUpdating = True
  
    Debug.Print Timer - t
End Sub
Nhấp chuột vào đây để mở rộng...

Dạ em đã test thử code phần ngành hàng đã xóa những mã hàng không thuộc sheet DATA_SP.
Tuy nhiên
- cột AY (LUOT KHACH MUA) ,
- cột AZ (SỐ BILL),
- cột BA ( DOANH THU)
Khi em xóa dữ liệu thì nó không xóa kết quả, anh hỗ trợ em phần này nhe
Em cám ơn
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, tmp
Dim result(), cot2(), ba(), change As Range, songayma As String, so_ngay_ma As Object, t
    t = Timer
    If Dic Is Nothing Then Vlookup_DATA_SP
   
    Application.EnableEvents = False
    Application.ScreenUpdating = False
   
    Set change = Intersect(Range("D851:D600000"), Target)
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ReDim Preserve result(1 To UBound(result), 1 To 3)
   
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) Then
                tmp = result(i, 1)
                If Dic.exists(tmp) Then
                    result(i, 1) = aResult(Dic.Item(tmp), 3) 'NGANH HANG
                    result(i, 2) = aResult(Dic.Item(tmp), 5) 'LOAI HANG
                    result(i, 3) = aResult(Dic.Item(tmp), 4) 'HANG
                Else
                    result(i, 1) = "KHÁC"
                    result(i, 2) = "KHÁC" ' Thêm
                    result(i, 3) = "KHÁC" ' Thêm
                End If
            End If
        Next i
        change.Offset(0, 36).Resize(, 3).Value = result
    End If
'    ngay thang
    Set change = Intersect(Target, Range("M851:M600000")) ' Ngay Thang Nam, Tuan
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ReDim Preserve result(1 To UBound(result), 1 To 5)
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) Then
                result(i, 2) = WorksheetFunction.Text(result(i, 1), "[$-42A]ddd")
                result(i, 3) = Format(result(i, 1), "d")
                result(i, 4) = Format(result(i, 1), "m")
                result(i, 5) = Format(result(i, 1), "yyyy")
                result(i, 1) = Format(result(i, 1), "ww")
            End If
        Next i
        change.Offset(0, 31).Resize(, 5).Value = result
    End If
'   Phan Khuc Gia va cot BA
    Set change = Intersect(Target, Range("AC851:AC600000"))
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ba = result
        For i = 1 To UBound(result) - 1
            ba(i, 1) = result(i, 1) / 1.1
            If Len(result(i, 1)) Then
                Select Case result(i, 1) / 10 ^ 6
                    Case Is <= 1: result(i, 1) = "<1M"
                    Case Is <= 2: result(i, 1) = "1M-2M"
                    Case Is <= 4: result(i, 1) = "2M-4M"
                    Case Is <= 6: result(i, 1) = "4M-6M"
                    Case Is <= 8: result(i, 1) = "6M-8M"
                    Case Is <= 10: result(i, 1) = "8M-10M"
                    Case Is <= 12: result(i, 1) = "10M-12M"
                    Case Is <= 14: result(i, 1) = "12M-14M"
                    Case Is <= 16: result(i, 1) = "14M-16M"
                    Case Is <= 18: result(i, 1) = "16M-18M"
                    Case Is <= 20: result(i, 1) = "18M-20M"
                    Case Else: result(i, 1) = "Tren 20M"
               End Select
            End If
        Next i
'        Phan Khuc Gia
        change.Offset(0, 14).Value = result
'        cot BA
        Range("BA" & change.Row).Resize(UBound(ba) - 1).Value = ba
    End If
'    cot AY
    Set change = Intersect(Target, Range("M851:M600000, P851:P600000"))
    If Not change Is Nothing Then
        Set so_ngay_ma = CreateObject("Scripting.Dictionary")
        result = Range("M" & change.Row).Resize(change.Rows.Count + 1).Value
        cot2 = Range("M" & change.Row).Offset(0, 3).Resize(change.Rows.Count + 1).Value
        For i = 1 To UBound(result) - 1
            songayma = result(i, 1) & "-" & cot2(i, 1)
            If so_ngay_ma.exists(songayma) Then
                result(i, 1) = 0
            Else
                result(i, 1) = 1
                so_ngay_ma.Add songayma, ""
            End If
        Next i
        Cells(change.Row, "AY").Resize(UBound(result) - 1).Value = result
        Set so_ngay_ma = Nothing
    End If
'    cot AZ
    Set change = Intersect(Target, Range("C851:C600000, M851:M600000"))
    If Not change Is Nothing Then
        Set so_ngay_ma = CreateObject("Scripting.Dictionary")
        result = Range("C" & change.Row).Resize(change.Rows.Count + 1).Value
        cot2 = Range("C" & change.Row).Offset(0, 10).Resize(change.Rows.Count + 1).Value
        For i = 1 To UBound(result) - 1
            songayma = result(i, 1) & "-" & cot2(i, 1)
            If so_ngay_ma.exists(songayma) Then
                result(i, 1) = 0
            Else
                result(i, 1) = 1
                so_ngay_ma.Add songayma, ""
            End If
        Next i
        Cells(change.Row, "AZ").Resize(UBound(result) - 1).Value = result
        Set so_ngay_ma = Nothing
    End If
   
    Application.EnableEvents = True
    Application.ScreenUpdating = True
   
    Debug.Print Timer - t
End Sub
 
LamNA đã viết:
Tuy nhiên
- cột AY (LUOT KHACH MUA) ,
- cột AZ (SỐ BILL),
- cột BA ( DOANH THU)
Khi em xóa dữ liệu thì nó không xóa kết quả, anh hỗ trợ em phần này nhe
Nhấp chuột vào đây để mở rộng...
Do bạn không nói nên tôi làm theo công thức thôi. Công thức không trả về chuỗi rỗng khi xóa dữ liệu nguồn
Mã: 
=N(COUNTIFS($P$3:P3;P3;$M$3:M3;M3)=1)
nên tôi làm đúng theo như thế.

Bạn đợi nhé. Hôm nay là ngày lễ mà :D
 
1. Chỉ cần hoặc M hoặc P rỗng thì cột AY rỗng. Tức không cần đồng thời M và P rỗng. Tất nhiên theo lôgíc thì khi M rỗng thì P cũng phải rỗng. Nhưng đây là việc của người "đổ dữ liệu vào sheet"
2. Chỉ cần hoặc C hoặc M rỗng thì cột AZ rỗng. Tức không cần đồng thời C và M rỗng. Tất nhiên theo lôgíc thì khi C rỗng thì M cũng phải rỗng. Nhưng đây là việc của người "đổ dữ liệu vào sheet"

Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, tmp
Dim result(), cot2(), ba(), change As Range, songayma As String, so_ngay_ma As Object   
  
    Application.EnableEvents = False
    Application.ScreenUpdating = False
  
    Set change = Intersect(Range("D851:D600000"), Target)
    If Not change Is Nothing Then
        If Dic Is Nothing Then Vlookup_DATA_SP
        result = change.Resize(change.Rows.Count + 1).Value
        ReDim Preserve result(1 To UBound(result), 1 To 3)
  
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) Then
                tmp = result(i, 1)
                If Dic.exists(tmp) Then
                    result(i, 1) = aResult(Dic.Item(tmp), 3) 'NGANH HANG
                    result(i, 2) = aResult(Dic.Item(tmp), 5) 'LOAI HANG
                    result(i, 3) = aResult(Dic.Item(tmp), 4) 'HANG
                Else
                    result(i, 1) = "KHÁC"
                    result(i, 2) = "KHÁC" ' Them
                    result(i, 3) = "KHÁC" ' Them
                End If
            End If
        Next i
        change.Offset(0, 36).Resize(, 3).Value = result
    End If
'    ngay thang
    Set change = Intersect(Target, Range("M851:M600000")) ' Ngay Thang Nam, Tuan
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ReDim Preserve result(1 To UBound(result), 1 To 5)
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) Then
                result(i, 2) = WorksheetFunction.Text(result(i, 1), "[$-42A]ddd")
                result(i, 3) = Format(result(i, 1), "d")
                result(i, 4) = Format(result(i, 1), "m")
                result(i, 5) = Format(result(i, 1), "yyyy")
                result(i, 1) = Format(result(i, 1), "ww")
            End If
        Next i
        change.Offset(0, 31).Resize(, 5).Value = result
    End If
'   Phan Khuc Gia va cot BA
    Set change = Intersect(Target, Range("AC851:AC600000"))
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ba = result
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) Then
                ba(i, 1) = result(i, 1) / 1.1
                Select Case result(i, 1) / 10 ^ 6
                    Case Is <= 1: result(i, 1) = "<1M"
                    Case Is <= 2: result(i, 1) = "1M-2M"
                    Case Is <= 4: result(i, 1) = "2M-4M"
                    Case Is <= 6: result(i, 1) = "4M-6M"
                    Case Is <= 8: result(i, 1) = "6M-8M"
                    Case Is <= 10: result(i, 1) = "8M-10M"
                    Case Is <= 12: result(i, 1) = "10M-12M"
                    Case Is <= 14: result(i, 1) = "12M-14M"
                    Case Is <= 16: result(i, 1) = "14M-16M"
                    Case Is <= 18: result(i, 1) = "16M-18M"
                    Case Is <= 20: result(i, 1) = "18M-20M"
                    Case Else: result(i, 1) = "Tren 20M"
               End Select
            End If
        Next i
'        Phan Khuc Gia
        change.Offset(0, 14).Value = result
'        cot BA
        Range("BA" & change.Row).Resize(UBound(ba) - 1).Value = ba
    End If
'    cot AY
    Set change = Intersect(Target, Range("M851:M600000, P851:P600000"))
    If Not change Is Nothing Then
        Set so_ngay_ma = CreateObject("Scripting.Dictionary")
        result = Range("M" & change.Row).Resize(change.Rows.Count + 1).Value
        cot2 = Range("M" & change.Row).Offset(0, 3).Resize(change.Rows.Count + 1).Value
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) And Len(cot2(i, 1)) Then
                songayma = result(i, 1) & "-" & cot2(i, 1)
                If so_ngay_ma.exists(songayma) Then
                    result(i, 1) = 0
                Else
                    result(i, 1) = 1
                    so_ngay_ma.Add songayma, ""
                End If
            Else
                result(i, 1) = Empty
            End If
        Next i
        Cells(change.Row, "AY").Resize(UBound(result) - 1).Value = result
        Set so_ngay_ma = Nothing
    End If
'    cot AZ
    Set change = Intersect(Target, Range("C851:C600000, M851:M600000"))
    If Not change Is Nothing Then
        Set so_ngay_ma = CreateObject("Scripting.Dictionary")
        result = Range("C" & change.Row).Resize(change.Rows.Count + 1).Value
        cot2 = Range("C" & change.Row).Offset(0, 10).Resize(change.Rows.Count + 1).Value
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) And Len(cot2(i, 1)) Then
                songayma = result(i, 1) & "-" & cot2(i, 1)
                If so_ngay_ma.exists(songayma) Then
                    result(i, 1) = 0
                Else
                    result(i, 1) = 1
                    so_ngay_ma.Add songayma, ""
                End If
            Else
                result(i, 1) = Empty
            End If
        Next i
        Cells(change.Row, "AZ").Resize(UBound(result) - 1).Value = result
        Set so_ngay_ma = Nothing
    End If
  
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
 
Lần chỉnh sửa cuối:
batman1 đã viết:
1. Chỉ cần hoặc M hoặc P rỗng thì cột AY rỗng. Tức không cần đồng thời M và P rỗng. Tất nhiên theo lôgíc thì khi M rỗng thì P cũng phải rỗng. Nhưng đây là việc của người "đổ dữ liệu vào sheet"
2. Chỉ cần hoặc C hoặc M rỗng thì cột AZ rỗng. Tức không cần đồng thời C và M rỗng. Tất nhiên theo lôgíc thì khi C rỗng thì M cũng phải rỗng. Nhưng đây là việc của người "đổ dữ liệu vào sheet"

Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, tmp
Dim result(), cot2(), ba(), change As Range, songayma As String, so_ngay_ma As Object  
 
    Application.EnableEvents = False
    Application.ScreenUpdating = False
 
    Set change = Intersect(Range("D851:D600000"), Target)
    If Not change Is Nothing Then
        If Dic Is Nothing Then Vlookup_DATA_SP
        result = change.Resize(change.Rows.Count + 1).Value
        ReDim Preserve result(1 To UBound(result), 1 To 3)
 
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) Then
                tmp = result(i, 1)
                If Dic.exists(tmp) Then
                    result(i, 1) = aResult(Dic.Item(tmp), 3) 'NGANH HANG
                    result(i, 2) = aResult(Dic.Item(tmp), 5) 'LOAI HANG
                    result(i, 3) = aResult(Dic.Item(tmp), 4) 'HANG
                Else
                    result(i, 1) = "KHÁC"
                    result(i, 2) = "KHÁC" ' Them
                    result(i, 3) = "KHÁC" ' Them
                End If
            End If
        Next i
        change.Offset(0, 36).Resize(, 3).Value = result
    End If
'    ngay thang
    Set change = Intersect(Target, Range("M851:M600000")) ' Ngay Thang Nam, Tuan
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ReDim Preserve result(1 To UBound(result), 1 To 5)
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) Then
                result(i, 2) = WorksheetFunction.Text(result(i, 1), "[$-42A]ddd")
                result(i, 3) = Format(result(i, 1), "d")
                result(i, 4) = Format(result(i, 1), "m")
                result(i, 5) = Format(result(i, 1), "yyyy")
                result(i, 1) = Format(result(i, 1), "ww")
            End If
        Next i
        change.Offset(0, 31).Resize(, 5).Value = result
    End If
'   Phan Khuc Gia va cot BA
    Set change = Intersect(Target, Range("AC851:AC600000"))
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ba = result
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) Then
                ba(i, 1) = result(i, 1) / 1.1
                Select Case result(i, 1) / 10 ^ 6
                    Case Is <= 1: result(i, 1) = "<1M"
                    Case Is <= 2: result(i, 1) = "1M-2M"
                    Case Is <= 4: result(i, 1) = "2M-4M"
                    Case Is <= 6: result(i, 1) = "4M-6M"
                    Case Is <= 8: result(i, 1) = "6M-8M"
                    Case Is <= 10: result(i, 1) = "8M-10M"
                    Case Is <= 12: result(i, 1) = "10M-12M"
                    Case Is <= 14: result(i, 1) = "12M-14M"
                    Case Is <= 16: result(i, 1) = "14M-16M"
                    Case Is <= 18: result(i, 1) = "16M-18M"
                    Case Is <= 20: result(i, 1) = "18M-20M"
                    Case Else: result(i, 1) = "Tren 20M"
               End Select
            End If
        Next i
'        Phan Khuc Gia
        change.Offset(0, 14).Value = result
'        cot BA
        Range("BA" & change.Row).Resize(UBound(ba) - 1).Value = ba
    End If
'    cot AY
    Set change = Intersect(Target, Range("M851:M600000, P851:P600000"))
    If Not change Is Nothing Then
        Set so_ngay_ma = CreateObject("Scripting.Dictionary")
        result = Range("M" & change.Row).Resize(change.Rows.Count + 1).Value
        cot2 = Range("M" & change.Row).Offset(0, 3).Resize(change.Rows.Count + 1).Value
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) And Len(cot2(i, 1)) Then
                songayma = result(i, 1) & "-" & cot2(i, 1)
                If so_ngay_ma.exists(songayma) Then
                    result(i, 1) = 0
                Else
                    result(i, 1) = 1
                    so_ngay_ma.Add songayma, ""
                End If
            Else
                result(i, 1) = Empty
            End If
        Next i
        Cells(change.Row, "AY").Resize(UBound(result) - 1).Value = result
        Set so_ngay_ma = Nothing
    End If
'    cot AZ
    Set change = Intersect(Target, Range("C851:C600000, M851:M600000"))
    If Not change Is Nothing Then
        Set so_ngay_ma = CreateObject("Scripting.Dictionary")
        result = Range("C" & change.Row).Resize(change.Rows.Count + 1).Value
        cot2 = Range("C" & change.Row).Offset(0, 10).Resize(change.Rows.Count + 1).Value
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) And Len(cot2(i, 1)) Then
                songayma = result(i, 1) & "-" & cot2(i, 1)
                If so_ngay_ma.exists(songayma) Then
                    result(i, 1) = 0
                Else
                    result(i, 1) = 1
                    so_ngay_ma.Add songayma, ""
                End If
            Else
                result(i, 1) = Empty
            End If
        Next i
        Cells(change.Row, "AZ").Resize(UBound(result) - 1).Value = result
        Set so_ngay_ma = Nothing
    End If
 
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Quá tuyệt vời
Em cám ơn anh nhe
 
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

D
Nhờ các bác giúp đỡ vấn đề tìm kiếm dữ liệu (3 người xem)
Trả lời
1
Đọc
27
Hoàng Tuấn 868
H
D
  • Đã giải quyết
Quản lý email outlook qua VBA cần giúp đỡ
2
Trả lời
24
Đọc
825
tle2003
T
A
NHỜ ANH CHỊ GIÚP EM CÂU LỆNH NÀY VỚI Ạ (2 người xem)
Trả lời
1
Đọc
94
ongke0711
ongke0711
P
Hỏi về cách dò tìm từ dưới lên trên, dò tìm trong 2 bảng (1 người xem)
Trả lời
6
Đọc
149
pqdowntailieu3
P
H
Chuyển file *xml hóa đơn điện tử sang excel (1 người xem)
    • Thích
Trả lời
4
Đọc
186
htrunga2
H
K
Lọc một mã sản phẩm có nhiều đơn giá thành một file riêng
Trả lời
2
Đọc
96
ketoansb123
K
D
Nhờ trợ giúp xác định thứ tự của các từ và cụm từ trong 1 chuỗi văn bản. (1 người xem)
Trả lời
10
Đọc
258
Phuocam
Phuocam
P
Xin tư vấn về cách tạo bảng quản lý vải (2 người xem)
    • Cười
Trả lời
13
Đọc
201
Hai Lúa Miền Tây
Hai Lúa Miền Tây
1
Vướng mắc về hàm lấy tên đăng nhập máy tính ạ
Trả lời
19
Đọc
553
thuytrangbp28
T
Trungvt3
Công thức trả về định dạng không như mong muốn và viết phân số trong 1 ô. (1 người xem)
Trả lời
6
Đọc
188
Trungvt3
Trungvt3
H
  • Question Question
Tô đậm tiêu đề cho cho các sheet
Trả lời
4
Đọc
182
hieu998
H
GPE-Trợ Lý
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM (2 người xem)
    • Thích
Trả lời
1
Đọc
958
GPE-Trợ Lý
GPE-Trợ Lý
Z
TRỢ GIÚP K SORT ĐƯỢC THỨ TỰ NGÀY THÁNG NĂM TRONG EXCEL
Trả lời
2
Đọc
118
Duy Tùng 9x
Duy Tùng 9x
H
Tách file nguồn thành nhiều file dựa vào điều kiện
Trả lời
5
Đọc
174
LePhatHuy
LePhatHuy
F
  • Question Question
Tự động Merge Mail bằng VBA
Trả lời
7
Đọc
363
fujishima
F
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024)
    • Thích
2 3
Trả lời
49
Đọc
4K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
N
tính thể tích bồn dầu hình trụ elip nằm ngang
Trả lời
10
Đọc
47K
pvkiem
P
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện.
Trả lời
18
Đọc
413
tle2003
T
GPE-Trợ Lý
Đăng ký tham dự hội thảo tại Hà Nội: Power Query - Công cụ quản lý dữ liệu (1 người xem)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
14
Đọc
2K
GPE-Trợ Lý
GPE-Trợ Lý
G
Xin Code xóa Module.
Trả lời
10
Đọc
503
GCQ
G
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
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM
Back
Top Bottom