Đổi Ngày (dd/mm/yyyy) Thành Ngày - Tháng - Năm - Tuần - Thứ!! (6 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

Dạ em chạy code rất tốt, em cám ơn anh đã giúp đỡ
Anh có thể cho em hỏi thêm nếu em muốn tính thêm cột thứ theo Format: CN-T2-T3.....T7, thì mình thêm đoạn code như thế nào ạ
Em cám ơn

Chào anh
Em có 2 code chung 1 sheet nếu bỏ code trên thì chạy bình thường còn dùng chung 2 code thì nó sẽ báo lỗi "Private Sub Worksheet_Change1(ByVal Target As Range)"
Chắc do em không biết cách khai báo, nhờ anh hỗ trợ em cách viết nào là đúng để chạy được 2 code chung 1 sheet nhe
Em cám ơn
Mã:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rTarget As Range, aTarget, i As Long, n As Long
  Dim Arr1(), Arr2(), Arr3(), Arr4(), Arr5(), Arr6(), Arr7(), tmp
  On Error Resume Next
  If Dic Is Nothing Then Vlookup_DATA_SP
  If Not Intersect(Range("D851:D600000"), Target) Is Nothing Then
    Set rTarget = Intersect(Range("D851:D600000"), Target)
    If IsArray(rTarget.Value) Then
      aTarget = rTarget.Value
    Else
      ReDim aTarget(1 To 1, 1 To 1)
      aTarget(1, 1) = rTarget.Value
    End If
    ReDim Arr1(1 To UBound(aTarget, 1), 1 To 1)
    ReDim Arr2(1 To UBound(aTarget, 1), 1 To 1)
    ReDim Arr5(1 To UBound(aTarget, 1), 1 To 1)

    For i = 1 To UBound(aTarget, 1)
      If aTarget(i, 1) <> "" Then
        tmp = aTarget(i, 1)
        If Dic.Exists(tmp) Then
          Arr1(i, 1) = aResult(Dic.Item(tmp), 3) 'NGANH HANG
          Arr2(i, 1) = aResult(Dic.Item(tmp), 4) 'HANG
          Arr5(i, 1) = aResult(Dic.Item(tmp), 5) 'LOAI HANG


        End If
      End If
    Next
    rTarget.Offset(, 36).Resize(, 1).Value = Arr1 'Vi tri tham chieu NGANH HANG
    rTarget.Offset(, 38).Resize(, 1).Value = Arr2 'Vi tri tham chieu HANG
    rTarget.Offset(, 37).Resize(, 1).Value = Arr5 'Vi tri tham chieu LOAI HANG

  End If
End Sub


Private Sub Worksheet_Change1(ByVal Target As Range)
Dim rng As Range, change As Range
 
    Set change = Intersect(Target, Range("M851:M600000"))
    If Not change Is Nothing Then
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        For Each rng In change
            With rng
                .Offset(0, 34).Value = Format(rng, "d")
                .Offset(0, 35).Value = Format(rng, "m")
                .Offset(0, 36).Value = Format(rng, "yyyy")
                .Offset(0, 32).Value = Format(rng, "ww")
            End With
        Next rng
        Application.ScreenUpdating = True
        Application.EnableEvents = True
    End If
End Sub
 
Không đơn giản thế đâu.
1. Theo lôgíc của tôi thì khi nhập ngày tháng ở A thì trong 5 cột tiếp theo sẽ có kết quả. Vậy khi xóa A thì 5 cột kia cũng phải rỗng. Nhưng trong code của bạn khi xóa A thì dDate = 0, như vậy trong 5 cột vẫn có dữ liệu - của những năm tháng xa xôi.

2. Người ta có

Người ta không nói kéo xuống bao nhiêu nên để đề phòng kéo hàng ngàn dòng thì tôi có vd. Application.ScreenUpdating = False / True.

Khi người ta kéo như thế thì Target là nhiều cell nên chắc chắn có lỗi ở dòng
Mã:
.Offset(0, 1).Resize(1, 5) = ConvertDate2ABC(CLng(Val(Target.Value2)))
Target.Value2 là cả một mảng giá trị nên CLng(Val(Target.Value2)) sẽ có lỗi.
(1) thì thôi ạ.
(2) Em sửa lại: .Offset(0, 1).Resize(1, 5) = ConvertDate2ABC(CLng(Val(.Value2))) được không anh?

Chúc anh tối vui!
 
Đây không phải procedure bình thường để bạn khai báo tên bất kỳ.
Private Sub Worksheet_Change() có nghĩa là đây là procedure phục vụ sự kiện "thay đổi" trên sheet, và nó sẽ được gọi khi có sự thay đổi nào đó trên sheet.

Bạn click để mở combobox ở bên phải thì thấy có dòng "Change". Tức đối tượng sheet có event procedure với tên là Change. Làm gì có event Change1? Nếu bạn có Private Sub Worksheet_Change1() thì lúc đó nó được coi là procedure bình thường có tên là Worksheet_Change1. Nó không phải là event procedure. Thế thôi. Procedure ấy sẽ vô dụng vì không được gọi khi có sự thay đổi trên sheet.

Nếu cần thì gộp 2 thành 1. Tôi chỉ gộp cho bạn thôi chứ không sửa, không làm tối ưu code đầu. Bạn tự làm.
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rTarget As Range, aTarget, i As Long, n As Long
Dim Arr1(), Arr2(), Arr3(), Arr4(), Arr5(), Arr6(), Arr7(), tmp
Dim rng As Range, change As Range
    On Error Resume Next
    If dic Is Nothing Then Vlookup_DATA_SP
    If Not Intersect(Range("D851:D600000"), Target) Is Nothing Then
        Set rTarget = Intersect(Range("D851:D600000"), Target)
        If IsArray(rTarget.Value) Then
            aTarget = rTarget.Value
        Else
            ReDim aTarget(1 To 1, 1 To 1)
            aTarget(1, 1) = rTarget.Value
        End If
        ReDim Arr1(1 To UBound(aTarget, 1), 1 To 1)
        ReDim Arr2(1 To UBound(aTarget, 1), 1 To 1)
        ReDim Arr5(1 To UBound(aTarget, 1), 1 To 1)
    
        For i = 1 To UBound(aTarget, 1)
            If aTarget(i, 1) <> "" Then
                tmp = aTarget(i, 1)
                If dic.Exists(tmp) Then
                    Arr1(i, 1) = aResult(dic.Item(tmp), 3) 'NGANH HANG
                    Arr2(i, 1) = aResult(dic.Item(tmp), 4) 'HANG
                    Arr5(i, 1) = aResult(dic.Item(tmp), 5) 'LOAI HANG
                End If
            End If
        Next
        rTarget.Offset(, 36).Resize(, 1).Value = Arr1 'Vi tri tham chieu NGANH HANG
        rTarget.Offset(, 38).Resize(, 1).Value = Arr2 'Vi tri tham chieu HANG
        rTarget.Offset(, 37).Resize(, 1).Value = Arr5 'Vi tri tham chieu LOAI HANG
    Else
        Set change = Intersect(Target, Range("M851:M600000"))
        If Not change Is Nothing Then
            Application.EnableEvents = False
            Application.ScreenUpdating = False
            For Each rng In change
                With rng
                    .Offset(0, 34).Value = Format(rng, "d")
                    .Offset(0, 35).Value = Format(rng, "m")
                    .Offset(0, 36).Value = Format(rng, "yyyy")
                    .Offset(0, 32).Value = Format(rng, "ww")
                End With
            Next rng
            Application.ScreenUpdating = True
            Application.EnableEvents = True
        End If
    End If
End Sub
 
(2) Em sửa lại: .Offset(0, 1).Resize(1, 5) = ConvertDate2ABC(CLng(Val(.Value2))) được không anh?
Tôi không bao giờ thích những câu hỏi như thế này. Khi đã biết cần phải xét những trường hợp như thế nào thì mỗi người tự kiểm tra thôi chứ sao lại phải hỏi? :D
 
Đây không phải procedure bình thường để bạn khai báo tên bất kỳ.
Private Sub Worksheet_Change() có nghĩa là đây là procedure phục vụ sự kiện "thay đổi" trên sheet, và nó sẽ được gọi khi có sự thay đổi nào đó trên sheet.

Bạn click để mở combobox ở bên phải thì thấy có dòng "Change". Tức đối tượng sheet có event procedure với tên là Change. Làm gì có event Change1? Nếu bạn có Private Sub Worksheet_Change1() thì lúc đó nó được coi là procedure bình thường có tên là Worksheet_Change1. Nó không phải là event procedure. Thế thôi. Procedure ấy sẽ vô dụng vì không được gọi khi có sự thay đổi trên sheet.

Nếu cần thì gộp 2 thành 1. Tôi chỉ gộp cho bạn thôi chứ không sửa, không làm tối ưu code đầu. Bạn tự làm.
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rTarget As Range, aTarget, i As Long, n As Long
Dim Arr1(), Arr2(), Arr3(), Arr4(), Arr5(), Arr6(), Arr7(), tmp
Dim rng As Range, change As Range
    On Error Resume Next
    If dic Is Nothing Then Vlookup_DATA_SP
    If Not Intersect(Range("D851:D600000"), Target) Is Nothing Then
        Set rTarget = Intersect(Range("D851:D600000"), Target)
        If IsArray(rTarget.Value) Then
            aTarget = rTarget.Value
        Else
            ReDim aTarget(1 To 1, 1 To 1)
            aTarget(1, 1) = rTarget.Value
        End If
        ReDim Arr1(1 To UBound(aTarget, 1), 1 To 1)
        ReDim Arr2(1 To UBound(aTarget, 1), 1 To 1)
        ReDim Arr5(1 To UBound(aTarget, 1), 1 To 1)
   
        For i = 1 To UBound(aTarget, 1)
            If aTarget(i, 1) <> "" Then
                tmp = aTarget(i, 1)
                If dic.Exists(tmp) Then
                    Arr1(i, 1) = aResult(dic.Item(tmp), 3) 'NGANH HANG
                    Arr2(i, 1) = aResult(dic.Item(tmp), 4) 'HANG
                    Arr5(i, 1) = aResult(dic.Item(tmp), 5) 'LOAI HANG
                End If
            End If
        Next
        rTarget.Offset(, 36).Resize(, 1).Value = Arr1 'Vi tri tham chieu NGANH HANG
        rTarget.Offset(, 38).Resize(, 1).Value = Arr2 'Vi tri tham chieu HANG
        rTarget.Offset(, 37).Resize(, 1).Value = Arr5 'Vi tri tham chieu LOAI HANG
    Else
        Set change = Intersect(Target, Range("M851:M600000"))
        If Not change Is Nothing Then
            Application.EnableEvents = False
            Application.ScreenUpdating = False
            For Each rng In change
                With rng
                    .Offset(0, 34).Value = Format(rng, "d")
                    .Offset(0, 35).Value = Format(rng, "m")
                    .Offset(0, 36).Value = Format(rng, "yyyy")
                    .Offset(0, 32).Value = Format(rng, "ww")
                End With
            Next rng
            Application.ScreenUpdating = True
            Application.EnableEvents = True
        End If
    End If
End Sub

Chào anh!
có nghĩa nếu ta cần viết nối thêm 1 code nào đó trong 1 sheet ta chỉ cần viết "Else" đúng không anh?
Theo em hiều như code anh viết cho em
Em cám ơn
 
Thực ra cũng tùy. Thực ra có thể viết không có ELSE
Mã:
If Not Intersect(Range("D851:D600000"), Target) Is Nothing Then
...
End If
Set change = Intersect(Target, Range("M851:M600000"))
If Not change Is Nothing Then
    ...
End If
Nếu bạn thay đổi chỉ cột D hoặc M thì code trước và code này như nhau. Nhưng nếu bạn dán 1 lần vào cả 2 cột D và M thì có sự khác nhau. Code trước chỉ thực hiện phần trước ELSE. Code sau thì thực hiện cả cho sự thay đổi trong cột D và cả cho sự thay đổi trong cột M. Do bạn chỉ tung code lên mà không giải thích gì thêm nên tôi gộp với ELSE. Nhưng phải ý thức được là có trường hợp, dù là lý thuyết, khi bạn dán vào đồng thời 2 cột D và M. Nếu lúc đó bạn muốn xử lý cả 2 hậu quả thì phải dùng code không có ELSE ở trên.
 
Thực ra cũng tùy. Thực ra có thể viết không có ELSE
Mã:
If Not Intersect(Range("D851:D600000"), Target) Is Nothing Then
...
End If
Set change = Intersect(Target, Range("M851:M600000"))
If Not change Is Nothing Then
    ...
End If
Nếu bạn thay đổi chỉ cột D hoặc M thì code trước và code này như nhau. Nhưng nếu bạn dán 1 lần vào cả 2 cột D và M thì có sự khác nhau. Code trước chỉ thực hiện phần trước ELSE. Code sau thì thực hiện cả cho sự thay đổi trong cột D và cả cho sự thay đổi trong cột M. Do bạn chỉ tung code lên mà không giải thích gì thêm nên tôi gộp với ELSE. Nhưng phải ý thức được là có trường hợp, dù là lý thuyết, khi bạn dán vào đồng thời 2 cột D và M. Nếu lúc đó bạn muốn xử lý cả 2 hậu quả thì phải dùng code không có ELSE ở trên.

Dạ anh!
Các dữ liệu cột D và M em đều muốn thay đổi mỗi khi thay số liệu, hiện tại em test thôi code anh hướng dẫn đang chạy rất hoàn hảo, giảm đi dung lượng đáng kể thay vì dùng hàm.
Sẵn tiện anh hỗ trợ em cách thay hàm if và giá như file đính kèm, mục đích dùng code để tối ưu hóa báo cáo trong kinh doanh của em
Nó sẽ hoàn hảo khi giải quyết được tất cả như trong file
Em cám ơn
 

File đính kèm

Dạ anh!
Các dữ liệu cột D và M em đều muốn thay đổi mỗi khi thay số liệu, hiện tại em test thôi code anh hướng dẫn đang chạy rất hoàn hảo, giảm đi dung lượng đáng kể thay vì dùng hàm.
Tôi biết là bạn xử lý sự thay đổi ở cột D, M. Ý tôi nói là có sự khác biệt khi chỉ thay đổi D hoặc M, và lúc khác lại D hoặc M và trường hợp khi bạn đồng thời thay đổi cả D và M.
Sẵn tiện anh hỗ trợ em cách thay hàm if và giá như file đính kèm, mục đích dùng code để tối ưu hóa báo cáo trong kinh doanh của em
Nó sẽ hoàn hảo khi giải quyết được tất cả như trong file
Hiện tại tôi đang phải dịch một bản tài liệu sang tiếng Việt. Chưa biết khi nào xong.

Mà theo nội qui thì hình như mỗi chủ đề chỉ là một vấn đề. Có thể bạn phải lập chủ đề khác.
 
Thế trong cột Y có công thức hay dữ liệu nhập bằng tay, bằng máy?
Nếu không phải công thức thì:
1. Xóa toàn bộ công thức trong cột AQ.
2. Trong Worksheet_Change thêm đoạn
Mã:
Set change = Intersect(Target, Range("Y3:Y600000"))
If Not change Is Nothing Then
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    For Each rng In change
        If Len(rng.Value) Then
            Select Case rng.Value / 10 ^ 6
                Case Is <= 1: rng.Offset(0, 18).Value = "<1M"
                Case Is <= 2: rng.Offset(0, 18).Value = "1M-2M"
                Case Is <= 4: rng.Offset(0, 18).Value = "2M-4M"
                Case Is <= 6: rng.Offset(0, 18).Value = "4M-6M"
                Case Is <= 8: rng.Offset(0, 18).Value = "6M-8M"
                Case Is <= 10: rng.Offset(0, 18).Value = "8M-10M"
                Case Is <= 12: rng.Offset(0, 18).Value = "10M-12M"
                Case Is <= 14: rng.Offset(0, 18).Value = "12M-14M"
                Case Is <= 16: rng.Offset(0, 18).Value = "14M-16M"
                Case Is <= 18: rng.Offset(0, 18).Value = "16M-18M"
                Case Is <= 20: rng.Offset(0, 18).Value = "18M-20M"
                Case Else: rng.Offset(0, 18).Value = "Tren 20M"
            End Select
        Else
            rng.Offset(0, 18).Value = Empty
        End If
    Next rng
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End If
Cách thêm thì tôi đã giải thích rồi, bạn tự chọn.

Có thể thay đoạn
Mã:
Select Case rng.Value / 10 ^ 6
...
End Select
bằng Application.VLookup. Bạn tự đọc, tự nghiên cứu.

Vì code vào giữa chừng cuộc chơi nên nó không thể phản ứng với những dữ liệu đã có trong cột Y - sự kiện Change đã sảy ra hôm qua, tuần trước. Vì thế nếu đã có dữ liệu trong cột Y thì làm 1 lần các thao tác: Chọn toàn bộ dữ liệu cột Y -> nhấn Ctrl + C -> nhấn Ctrl + V (mục đích để tạo ra sự kiện Change cho những dữ liệu đã có)

Xóa dữ liệu cột Y thì cột AQ sẽ rỗng.
 
Thế trong cột Y có công thức hay dữ liệu nhập bằng tay, bằng máy?
Nếu không phải công thức thì:
1. Xóa toàn bộ công thức trong cột AQ.
2. Trong Worksheet_Change thêm đoạn
Mã:
Set change = Intersect(Target, Range("Y3:Y600000"))
If Not change Is Nothing Then
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    For Each rng In change
        If Len(rng.Value) Then
            Select Case rng.Value / 10 ^ 6
                Case Is <= 1: rng.Offset(0, 18).Value = "<1M"
                Case Is <= 2: rng.Offset(0, 18).Value = "1M-2M"
                Case Is <= 4: rng.Offset(0, 18).Value = "2M-4M"
                Case Is <= 6: rng.Offset(0, 18).Value = "4M-6M"
                Case Is <= 8: rng.Offset(0, 18).Value = "6M-8M"
                Case Is <= 10: rng.Offset(0, 18).Value = "8M-10M"
                Case Is <= 12: rng.Offset(0, 18).Value = "10M-12M"
                Case Is <= 14: rng.Offset(0, 18).Value = "12M-14M"
                Case Is <= 16: rng.Offset(0, 18).Value = "14M-16M"
                Case Is <= 18: rng.Offset(0, 18).Value = "16M-18M"
                Case Is <= 20: rng.Offset(0, 18).Value = "18M-20M"
                Case Else: rng.Offset(0, 18).Value = "Tren 20M"
            End Select
        Else
            rng.Offset(0, 18).Value = Empty
        End If
    Next rng
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End If
Cách thêm thì tôi đã giải thích rồi, bạn tự chọn.

Có thể thay đoạn
Mã:
Select Case rng.Value / 10 ^ 6
...
End Select
bằng Application.VLookup. Bạn tự đọc, tự nghiên cứu.

Vì code vào giữa chừng cuộc chơi nên nó không thể phản ứng với những dữ liệu đã có trong cột Y - sự kiện Change đã sảy ra hôm qua, tuần trước. Vì thế nếu đã có dữ liệu trong cột Y thì làm 1 lần các thao tác: Chọn toàn bộ dữ liệu cột Y -> nhấn Ctrl + C -> nhấn Ctrl + V (mục đích để tạo ra sự kiện Change cho những dữ liệu đã có)

Xóa dữ liệu cột Y thì cột AQ sẽ rỗng.

Em nối code bằng "Else" báo lỗi, em đã thử các cách thay thế như anh hướng dẫn đều không được. anh có thể giải thích thêm em đang thao tác sai ở chỗ nào không anh?
Em cám ơn
 
Thế trong cột Y có công thức hay dữ liệu nhập bằng tay, bằng máy?
Nếu không phải công thức thì:
1. Xóa toàn bộ công thức trong cột AQ.
2. Trong Worksheet_Change thêm đoạn
Mã:
Set change = Intersect(Target, Range("Y3:Y600000"))
If Not change Is Nothing Then
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    For Each rng In change
        If Len(rng.Value) Then
            Select Case rng.Value / 10 ^ 6
                Case Is <= 1: rng.Offset(0, 18).Value = "<1M"
                Case Is <= 2: rng.Offset(0, 18).Value = "1M-2M"
                Case Is <= 4: rng.Offset(0, 18).Value = "2M-4M"
                Case Is <= 6: rng.Offset(0, 18).Value = "4M-6M"
                Case Is <= 8: rng.Offset(0, 18).Value = "6M-8M"
                Case Is <= 10: rng.Offset(0, 18).Value = "8M-10M"
                Case Is <= 12: rng.Offset(0, 18).Value = "10M-12M"
                Case Is <= 14: rng.Offset(0, 18).Value = "12M-14M"
                Case Is <= 16: rng.Offset(0, 18).Value = "14M-16M"
                Case Is <= 18: rng.Offset(0, 18).Value = "16M-18M"
                Case Is <= 20: rng.Offset(0, 18).Value = "18M-20M"
                Case Else: rng.Offset(0, 18).Value = "Tren 20M"
            End Select
        Else
            rng.Offset(0, 18).Value = Empty
        End If
    Next rng
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End If
Cách thêm thì tôi đã giải thích rồi, bạn tự chọn.

Có thể thay đoạn
Mã:
Select Case rng.Value / 10 ^ 6
...
End Select
bằng Application.VLookup. Bạn tự đọc, tự nghiên cứu.

Vì code vào giữa chừng cuộc chơi nên nó không thể phản ứng với những dữ liệu đã có trong cột Y - sự kiện Change đã sảy ra hôm qua, tuần trước. Vì thế nếu đã có dữ liệu trong cột Y thì làm 1 lần các thao tác: Chọn toàn bộ dữ liệu cột Y -> nhấn Ctrl + C -> nhấn Ctrl + V (mục đích để tạo ra sự kiện Change cho những dữ liệu đã có)

Xóa dữ liệu cột Y thì cột AQ sẽ rỗng.

Cuối cùng em cũng mò ra được và chạy 3 code hàn hảo em cám ơn anh rất nhiều
 
Thế trong cột Y có công thức hay dữ liệu nhập bằng tay, bằng máy?
Nếu không phải công thức thì:
1. Xóa toàn bộ công thức trong cột AQ.
2. Trong Worksheet_Change thêm đoạn
Mã:
Set change = Intersect(Target, Range("Y3:Y600000"))
If Not change Is Nothing Then
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    For Each rng In change
        If Len(rng.Value) Then
            Select Case rng.Value / 10 ^ 6
                Case Is <= 1: rng.Offset(0, 18).Value = "<1M"
                Case Is <= 2: rng.Offset(0, 18).Value = "1M-2M"
                Case Is <= 4: rng.Offset(0, 18).Value = "2M-4M"
                Case Is <= 6: rng.Offset(0, 18).Value = "4M-6M"
                Case Is <= 8: rng.Offset(0, 18).Value = "6M-8M"
                Case Is <= 10: rng.Offset(0, 18).Value = "8M-10M"
                Case Is <= 12: rng.Offset(0, 18).Value = "10M-12M"
                Case Is <= 14: rng.Offset(0, 18).Value = "12M-14M"
                Case Is <= 16: rng.Offset(0, 18).Value = "14M-16M"
                Case Is <= 18: rng.Offset(0, 18).Value = "16M-18M"
                Case Is <= 20: rng.Offset(0, 18).Value = "18M-20M"
                Case Else: rng.Offset(0, 18).Value = "Tren 20M"
            End Select
        Else
            rng.Offset(0, 18).Value = Empty
        End If
    Next rng
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End If
Cách thêm thì tôi đã giải thích rồi, bạn tự chọn.

Có thể thay đoạn
Mã:
Select Case rng.Value / 10 ^ 6
...
End Select
bằng Application.VLookup. Bạn tự đọc, tự nghiên cứu.

Vì code vào giữa chừng cuộc chơi nên nó không thể phản ứng với những dữ liệu đã có trong cột Y - sự kiện Change đã sảy ra hôm qua, tuần trước. Vì thế nếu đã có dữ liệu trong cột Y thì làm 1 lần các thao tác: Chọn toàn bộ dữ liệu cột Y -> nhấn Ctrl + C -> nhấn Ctrl + V (mục đích để tạo ra sự kiện Change cho những dữ liệu đã có)

Xóa dữ liệu cột Y thì cột AQ sẽ rỗng
.

Về phần này anh nói rất đúng, nếu em đổ dữ liệu copy vào thì nó chỉ chạy code đầu tiền, riêng code ngày tháng năm tuần và phân khúc giá không chạy, mà phải copy và dán dòng tương úng thì nó mới chạy.
Mình có thể tối ưu hóa hoàn toàn tự động bằng cách khác không anh?

Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rTarget As Range, aTarget, i As Long, n As Long
Dim Arr1(), Arr2(), Arr3(), Arr4(), Arr5(), Arr6(), Arr7(), tmp
Dim rng As Range, change As Range

    On Error Resume Next
    If Dic Is Nothing Then Vlookup_DATA_SP
    If Not Intersect(Range("D851:D600000"), Target) Is Nothing Then
        Set rTarget = Intersect(Range("D851:D600000"), Target)
        If IsArray(rTarget.Value) Then
            aTarget = rTarget.Value
        Else
            ReDim aTarget(1 To 1, 1 To 1)
            aTarget(1, 1) = rTarget.Value
        End If
        ReDim Arr1(1 To UBound(aTarget, 1), 1 To 1)
        ReDim Arr2(1 To UBound(aTarget, 1), 1 To 1)
        ReDim Arr5(1 To UBound(aTarget, 1), 1 To 1)
    
        For i = 1 To UBound(aTarget, 1)
            If aTarget(i, 1) <> "" Then
                tmp = aTarget(i, 1)
                If Dic.Exists(tmp) Then
                    Arr1(i, 1) = aResult(Dic.Item(tmp), 3) 'NGANH HANG
                    Arr2(i, 1) = aResult(Dic.Item(tmp), 4) 'HANG
                    Arr5(i, 1) = aResult(Dic.Item(tmp), 5) 'LOAI HANG
                End If
            End If
        Next
        rTarget.Offset(, 36).Resize(, 1).Value = Arr1 'Vi tri tham chieu NGANH HANG
        rTarget.Offset(, 38).Resize(, 1).Value = Arr2 'Vi tri tham chieu HANG
        rTarget.Offset(, 37).Resize(, 1).Value = Arr5 'Vi tri tham chieu LOAI HANG
    Else
        Set change = Intersect(Target, Range("M851:M600000")) ' Ngay Thang Nam, Tuan
        If Not change Is Nothing Then
            Application.EnableEvents = False
            Application.ScreenUpdating = False
            For Each rng In change
                With rng
                    .Offset(0, 33).Value = Format(rng, "d")
                    .Offset(0, 34).Value = Format(rng, "m")
                    .Offset(0, 35).Value = Format(rng, "yyyy")
                    .Offset(0, 31).Value = Format(rng, "ww")
                End With
            Next rng
            Application.ScreenUpdating = True
            Application.EnableEvents = True
            
        Else 'Phan Khuc Gia
    Set change = Intersect(Target, Range("AC851:AC600000"))
If Not change Is Nothing Then
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
      For Each rng In change
        If Len(rng.Value) Then
    
            Select Case rng.Value / 10 ^ 6
                Case Is <= 1: rng.Offset(0, 14).Value = "<1M"
                Case Is <= 2: rng.Offset(0, 14).Value = "1M-2M"
                Case Is <= 4: rng.Offset(0, 14).Value = "2M-4M"
                Case Is <= 6: rng.Offset(0, 14).Value = "4M-6M"
                Case Is <= 8: rng.Offset(0, 14).Value = "6M-8M"
                Case Is <= 10: rng.Offset(0, 14).Value = "8M-10M"
                Case Is <= 12: rng.Offset(0, 14).Value = "10M-12M"
                Case Is <= 14: rng.Offset(0, 14).Value = "12M-14M"
                Case Is <= 16: rng.Offset(0, 14).Value = "14M-16M"
                Case Is <= 18: rng.Offset(0, 14).Value = "16M-18M"
                Case Is <= 20: rng.Offset(0, 14).Value = "18M-20M"
                Case Else: rng.Offset(0, 14).Value = "Tren 20M"
           End Select
        Else
            rng.Offset(0, 14).Value = Empty
        End If
    Next rng
    Application.EnableEvents = True
    Application.ScreenUpdating = True

    End If
    End If
    End If
    End Sub
 
Về phần này anh nói rất đúng, nếu em đổ dữ liệu copy vào thì nó chỉ chạy code đầu tiền, riêng code ngày tháng năm tuần và phân khúc giá không chạy, mà phải copy và dán dòng tương úng thì nó mới chạy.
Tôi đã nói với bạn là tùy vào trường hợp mà dùng. Có ai bắt dùng ELSE đâu?
Mà bạn hãy mô tả cái "đổ dữ liệu copy vào". Đổ thế nào, bằng cái gì, từ đâu tới đâu.
------
Mà nên giải thích kỹ cách hoạt động của tập tin. Trong Change bạn dùng dic và aResult. Chả biết dic được tạo ở đâu, khi nào. aResult mặt mũi thế nào. Vlookup_DATA_SP nằm ở đâu, làm những gì, việc làm có thay đổi gì trên sheet không. Vì lúc đó code đã tạo ra sự kiện Change ...
Không phải ai cũng thích mất thời gian, thích sửa đi sửa lại. Viết từng khúc riêng biệt để rồi chắp vá lại với nhau.
 
Lần chỉnh sửa cuối:
Tôi đã nói với bạn là tùy vào trường hợp mà dùng. Có ai bắt dùng ELSE đâu?
Mà bạn hãy mô tả cái "đổ dữ liệu copy vào". Đổ thế nào, bằng cái gì, từ đâu tới đâu.
------
Mà nên giải thích kỹ cách hoạt động của tập tin. Trong Change bạn dùng dic và aResult. Chả biết dic được tạo ở đâu, khi nào. aResult mặt mũi thế nào. Vlookup_DATA_SP nằm ở đâu, làm những gì, việc làm có thay đổi gì trên sheet không. Vì lúc đó code đã tạo ra sự kiện Change ...
Không phải ai cũng thích mất thời gian, thích sửa đi sửa lại. Viết từng khúc riêng biệt để rồi chắp vá lại với nhau.

Dạ em gửi file để anh dễ hiểu từng code như trên, anh xem giúp em nhe
Em cám ơn
 

File đính kèm

Dạ em gửi file để anh dễ hiểu từng code như trên, anh xem giúp em nhe
Em cám ơn
Tôi có viết
Mà bạn hãy mô tả cái "đổ dữ liệu copy vào". Đổ thế nào, bằng cái gì, từ đâu tới đâu.
Nhưng bạn không trả lời.

Thôi, tôi sửa thế này. Bạn tự kiểm tra.
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rTarget As Range, aTarget, i As Long, n As Long
Dim Arr1(), Arr2(), Arr3(), Arr4(), Arr5(), Arr6(), Arr7(), tmp
Dim rng As Range, change As Range

    On Error Resume Next
    If Dic Is Nothing Then Vlookup_DATA_SP
    If Not Intersect(Range("D851:D600000"), Target) Is Nothing Then
        Set rTarget = Intersect(Range("D851:D600000"), Target)
        If IsArray(rTarget.Value) Then
            aTarget = rTarget.Value
        Else
            ReDim aTarget(1 To 1, 1 To 1)
            aTarget(1, 1) = rTarget.Value
        End If
        ReDim Arr1(1 To UBound(aTarget, 1), 1 To 1)
        ReDim Arr2(1 To UBound(aTarget, 1), 1 To 1)
        ReDim Arr5(1 To UBound(aTarget, 1), 1 To 1)
    
        For i = 1 To UBound(aTarget, 1)
            If aTarget(i, 1) <> "" Then
                tmp = aTarget(i, 1)
                If Dic.Exists(tmp) Then
                    Arr1(i, 1) = aResult(Dic.Item(tmp), 3) 'NGANH HANG
                    Arr2(i, 1) = aResult(Dic.Item(tmp), 4) 'HANG
                    Arr5(i, 1) = aResult(Dic.Item(tmp), 5) 'LOAI HANG
                End If
            End If
        Next
        rTarget.Offset(, 36).Resize(, 1).Value = Arr1 'Vi tri tham chieu NGANH HANG
        rTarget.Offset(, 38).Resize(, 1).Value = Arr2 'Vi tri tham chieu HANG
        rTarget.Offset(, 37).Resize(, 1).Value = Arr5 'Vi tri tham chieu LOAI HANG
    End If
'    ngay thang
    Set change = Intersect(Target, Range("M851:M600000")) ' Ngay Thang Nam, Tuan
    If Not change Is Nothing Then
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        For Each rng In change
            With rng
                .Offset(0, 33).Value = Format(rng, "d")
                .Offset(0, 34).Value = Format(rng, "m")
                .Offset(0, 35).Value = Format(rng, "yyyy")
                .Offset(0, 31).Value = Format(rng, "ww")
            End With
        Next rng
        Application.ScreenUpdating = True
        Application.EnableEvents = True
    End If
'   Phan Khuc Gia
    Set change = Intersect(Target, Range("AC851:AC600000"))
    If Not change Is Nothing Then
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        For Each rng In change
            If Len(rng.Value) Then
                Select Case rng.Value / 10 ^ 6
                    Case Is <= 1: rng.Offset(0, 14).Value = "<1M"
                    Case Is <= 2: rng.Offset(0, 14).Value = "1M-2M"
                    Case Is <= 4: rng.Offset(0, 14).Value = "2M-4M"
                    Case Is <= 6: rng.Offset(0, 14).Value = "4M-6M"
                    Case Is <= 8: rng.Offset(0, 14).Value = "6M-8M"
                    Case Is <= 10: rng.Offset(0, 14).Value = "8M-10M"
                    Case Is <= 12: rng.Offset(0, 14).Value = "10M-12M"
                    Case Is <= 14: rng.Offset(0, 14).Value = "12M-14M"
                    Case Is <= 16: rng.Offset(0, 14).Value = "14M-16M"
                    Case Is <= 18: rng.Offset(0, 14).Value = "16M-18M"
                    Case Is <= 20: rng.Offset(0, 14).Value = "18M-20M"
                    Case Else: rng.Offset(0, 14).Value = "Tren 20M"
               End Select
            Else
                rng.Offset(0, 14).Value = Empty
            End If
        Next rng
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End Sub
 
Tôi có viết

Nhưng bạn không trả lời.

Thôi, tôi sửa thế này. Bạn tự kiểm tra.
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rTarget As Range, aTarget, i As Long, n As Long
Dim Arr1(), Arr2(), Arr3(), Arr4(), Arr5(), Arr6(), Arr7(), tmp
Dim rng As Range, change As Range

    On Error Resume Next
    If Dic Is Nothing Then Vlookup_DATA_SP
    If Not Intersect(Range("D851:D600000"), Target) Is Nothing Then
        Set rTarget = Intersect(Range("D851:D600000"), Target)
        If IsArray(rTarget.Value) Then
            aTarget = rTarget.Value
        Else
            ReDim aTarget(1 To 1, 1 To 1)
            aTarget(1, 1) = rTarget.Value
        End If
        ReDim Arr1(1 To UBound(aTarget, 1), 1 To 1)
        ReDim Arr2(1 To UBound(aTarget, 1), 1 To 1)
        ReDim Arr5(1 To UBound(aTarget, 1), 1 To 1)
   
        For i = 1 To UBound(aTarget, 1)
            If aTarget(i, 1) <> "" Then
                tmp = aTarget(i, 1)
                If Dic.Exists(tmp) Then
                    Arr1(i, 1) = aResult(Dic.Item(tmp), 3) 'NGANH HANG
                    Arr2(i, 1) = aResult(Dic.Item(tmp), 4) 'HANG
                    Arr5(i, 1) = aResult(Dic.Item(tmp), 5) 'LOAI HANG
                End If
            End If
        Next
        rTarget.Offset(, 36).Resize(, 1).Value = Arr1 'Vi tri tham chieu NGANH HANG
        rTarget.Offset(, 38).Resize(, 1).Value = Arr2 'Vi tri tham chieu HANG
        rTarget.Offset(, 37).Resize(, 1).Value = Arr5 'Vi tri tham chieu LOAI HANG
    End If
'    ngay thang
    Set change = Intersect(Target, Range("M851:M600000")) ' Ngay Thang Nam, Tuan
    If Not change Is Nothing Then
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        For Each rng In change
            With rng
                .Offset(0, 33).Value = Format(rng, "d")
                .Offset(0, 34).Value = Format(rng, "m")
                .Offset(0, 35).Value = Format(rng, "yyyy")
                .Offset(0, 31).Value = Format(rng, "ww")
            End With
        Next rng
        Application.ScreenUpdating = True
        Application.EnableEvents = True
    End If
'   Phan Khuc Gia
    Set change = Intersect(Target, Range("AC851:AC600000"))
    If Not change Is Nothing Then
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        For Each rng In change
            If Len(rng.Value) Then
                Select Case rng.Value / 10 ^ 6
                    Case Is <= 1: rng.Offset(0, 14).Value = "<1M"
                    Case Is <= 2: rng.Offset(0, 14).Value = "1M-2M"
                    Case Is <= 4: rng.Offset(0, 14).Value = "2M-4M"
                    Case Is <= 6: rng.Offset(0, 14).Value = "4M-6M"
                    Case Is <= 8: rng.Offset(0, 14).Value = "6M-8M"
                    Case Is <= 10: rng.Offset(0, 14).Value = "8M-10M"
                    Case Is <= 12: rng.Offset(0, 14).Value = "10M-12M"
                    Case Is <= 14: rng.Offset(0, 14).Value = "12M-14M"
                    Case Is <= 16: rng.Offset(0, 14).Value = "14M-16M"
                    Case Is <= 18: rng.Offset(0, 14).Value = "16M-18M"
                    Case Is <= 20: rng.Offset(0, 14).Value = "18M-20M"
                    Case Else: rng.Offset(0, 14).Value = "Tren 20M"
               End Select
            Else
                rng.Offset(0, 14).Value = Empty
            End If
        Next rng
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End Sub

Dạ trong file em có ghi chú cột màu đen

Zalo_ScreenShot_30_4_2018_106267.png
 
Thế bạn đã thử code tôi vừa sửa không?
 
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é.
 
Web KT

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

Back
Top Bottom