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

LamNA · 28/4/18

Chào anh chị GPE
Nhờ anh chị hỗ trợ code VBA có thể lọc ra ngày tháng năm tuần theo ngày tháng chỉ định, em có gửi file ví dụ đính kèm để anh chị dễ hiểu ạ
Em cám ơn

gttrongvn · 28/4/18

Cái này bạn dùng hàm được mà. Bạn muốn dùng code vba để làm gì?

Hoang2013 · 28/4/18

Bạn thao tác lọc nhờ AdvancedFilter cho thật nhuyễn;
Sau đó mở bộ thu macro lên & thu các thao tác lọc nêu trên là được 90% công việc theo iêu cầu của bạn rồi.

10% còn lại nhờ Cộng đồng sẽ trao chuốt cho bạn.

LamNA · 28/4/18

gttrongvn đã viết:
Cái này bạn dùng hàm được mà. Bạn muốn dùng code vba để làm gì?

Về hàm em xử lý được nhưng ý muốn tìm hiểu thêm về VBA, em quên là khi xử lý chuỗi xong nó mặc định xóa công thức chuyển trạng thái VALUES, nên cần dùng VBA để xử lý

LamNA · 28/4/18

Hoang2013 đã viết:
Bạn thao tác lọc nhờ AdvancedFilter cho thật nhuyễn;
Sau đó mở bộ thu macro lên & thu các thao tác lọc nêu trên là được 90% công việc theo iêu cầu của bạn rồi.

10% còn lại nhờ Cộng đồng sẽ trao chuốt cho bạn.

Phần thu Macro xong tạo nút bấm em xử lý được ý em muốn nó hoàn toàn tự động cho file. Hihi
Em cám ơn anh đã góp ý

truongvu317 · 28/4/18

Hời hợt quá! Lọc cái gì, lọc theo tiêu chí nào, kết quả lọc vứt vào đâu, và đây là file dữ liệu ảo, file thật đâu, viết code trên file ảo, rồi lại sửa tùm lum à.

LamNA · 28/4/18

truongvu317 đã viết:
Hời hợt quá! Lọc cái gì, lọc theo tiêu chí nào, kết quả lọc vứt vào đâu, và đây là file dữ liệu ảo, file thật đâu, viết code trên file ảo, rồi lại sửa tùm lum à.

File ví dụ cũng 1 phần rõ ràng rồi đó anh,
- Lọc cái gì: Lọc ngày tháng năm tuần ở A2:A21
- lọc theo tiêu chí nào, kết quả lọc vứt vào đâu: vứt vào ô Ngày, Tháng Năm, tuần
Như nội dung em chia sẻ nhằm mục đích tìm hiểu học VBA, vì thế mới có file ảo như vậy, thực tế không có file thật
Anh khó tính quá em út sợ không dám hỏi. Hihi
Em cám ơn

tle2003 · 29/4/18

Bạn gõ ngày vào cột A rồi enter , từ dòng 2 xuống, thì tự động cho kết quả.
Bạn xem có đúng ý không

LamNA · 29/4/18

tle2003 đã viết:
Bạn gõ ngày vào cột A rồi enter , từ dòng 2 xuống, thì tự động cho kết quả.
Bạn xem có đúng ý không

Dạ đúng ý của em nếu em muốn chạy hết cột B:B , C:C: , D

, E:E và mỗi khi thay đổi ngày nó sẽ tự động thay đổi và ngược lại xóa cột A nó sẽ xóa theo
Em cám ơn

LamNA · 29/4/18

tle2003 đã viết:
Bạn gõ ngày vào cột A rồi enter , từ dòng 2 xuống, thì tự động cho kết quả.
Bạn xem có đúng ý không

Em nhập ngày tháng từng ô thì chạy code nhưng khi copy hay kéo xuống thì nó lại báo lỗi, nhờ anh hỗ trợ giúp em nhe
Em cám ơn

LamNA · 29/4/18

LamNA đã viết:
Em nhập ngày tháng từng ô thì chạy code nhưng khi copy hay kéo xuống thì nó lại báo lỗi, nhờ anh hỗ trợ giúp em nhe
Em cám ơn

View attachment 194687

Em gửi file lại để dễ hình dung

LamNA · 29/4/18

Rất mong anh chị hỗ trợ trường hợp này giúp em ạ

Em nhập ngày tháng từng ô thì chạy code nhưng khi copy hay kéo xuống thì nó lại báo lỗi, nhờ anh hỗ trợ giúp em nhe
Em cám ơn

befaint · 29/4/18

LamNA đã viết:
Rất mong anh chị hỗ trợ trường hợp này giúp em ạ

Em nhập ngày tháng từng ô thì chạy code nhưng khi copy hay kéo xuống thì nó lại báo lỗi, nhờ anh hỗ trợ giúp em nhe
Em cám ơn

Lọc đâu mà lọc???? Rõ là đổi ngày (dd/mm/yyyy) thành ngày - tháng - năm - tuần - thứ!!!!!!!!!!!!!
Sửa lại cái tiêu đề cái nèo.

batman1 · 29/4/18

Thay bằng code mới

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, change As Range
    Set change = Intersect(Target, Range("A2:A500000"))
    If Not change Is Nothing Then
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        For Each rng In change
            With rng
                .Offset(0, 1).Value = Format(rng, "d")
                .Offset(0, 2).Value = Format(rng, "m")
                .Offset(0, 3).Value = Format(rng, "yyyy")
                .Offset(0, 4).Value = Format(rng, "ww")
            End With
        Next rng
        Application.ScreenUpdating = True
        Application.EnableEvents = True
    End If
End Sub

tle2003 · 29/4/18

Thêm phần Thứ vào code của batman1 , chắc lần này được rồi nghe.

befaint · 29/4/18

Rảnh nghịch tẹo...
Ở module

PHP:

Function ConvertDate2ABC(ByVal dDate As Long)
    Dim a(1 To 5)
    a(1) = Day(dDate)
    a(2) = Month(dDate)
    a(3) = Year(dDate)
   ' a(4) = Weekday(dDate)
    a(4) = WorksheetFunction.WeekNum(dDate)  'Sửa dòng này'
    a(5) = WorksheetFunction.Text(dDate, "[$-42A]dddd") 'Tiêng Viêt'
    'a(5) = WorksheetFunction.Text(dDate, "dddd") 'Tiêng Anh'
    ConvertDate2ABC = a
End Function

Ở worksheet

Mã:

Target.Offset(0, 1).Resize(1, 5) = ConvertDate2ABC(CLng(Val(Target.Value2)))
'Hoặc theo bài trên:'
[code]
With rng
   .Offset(0, 1).Resize(1, 5) = ConvertDate2ABC(CLng(Val(Target.Value2)))
End With

LamNA · 29/4/18

befaint đã viết:

Rảnh nghịch tẹo...
Ở module

PHP:

Function ConvertDate2ABC(ByVal dDate As Long)
    Dim a(1 To 5)
    a(1) = Day(dDate)
    a(2) = Month(dDate)
    a(3) = Year(dDate)
   ' a(4) = Weekday(dDate)
    a(4) = WorksheetFunction.WeekNum(dDate)  'Sửa dòng này'
    a(5) = WorksheetFunction.Text(dDate, "[$-42A]dddd") 'Tiêng Viêt'
    'a(5) = WorksheetFunction.Text(dDate, "dddd") 'Tiêng Anh'
    ConvertDate2ABC = a
End Function

Ở worksheet

Mã:

Target.Offset(0, 1).Resize(1, 5) = ConvertDate2ABC(CLng(Val(Target.Value2)))
'Hoặc theo bài trên:'
[code]
With rng
   .Offset(0, 1).Resize(1, 5) = ConvertDate2ABC(CLng(Val(Target.Value2)))
End With

Em đã thử mà hình như nó không chạy được code, chắc em sai ở đâu đó.
Em cám ơn đã hỗ trợ

LamNA · 29/4/18

batman1 đã viết:

Thay bằng code mới

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, change As Range
    Set change = Intersect(Target, Range("A2:A500000"))
    If Not change Is Nothing Then
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        For Each rng In change
            With rng
                .Offset(0, 1).Value = Format(rng, "d")
                .Offset(0, 2).Value = Format(rng, "m")
                .Offset(0, 3).Value = Format(rng, "yyyy")
                .Offset(0, 4).Value = Format(rng, "ww")
            End With
        Next rng
        Application.ScreenUpdating = True
        Application.EnableEvents = True
    End If
End Sub

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

batman1 · 29/4/18

befaint đã viết:
Rảnh nghịch tẹo...
Ở module

PHP:

Function ConvertDate2ABC(ByVal dDate As Long) ... ConvertDate2ABC = a End Function

Ở worksheet

'Hoặc theo bài trên:'

With rng
.Offset(0, 1).Resize(1, 5) = ConvertDate2ABC(CLng(Val(Target.Value2)))
End With

Không đơn giản thế đâu.
1. Theo lôgíc của tôi thì khi nhập ngày tháng ở A thì trong 5 cột tiếp theo sẽ có kết quả. Vậy khi xóa A thì 5 cột kia cũng phải rỗng. Nhưng trong code của bạn khi xóa A thì dDate = 0, như vậy trong 5 cột vẫn có dữ liệu - của những năm tháng xa xôi.

2. Người ta có

nhưng khi copy hay kéo xuống

Người ta không nói kéo xuống bao nhiêu nên để đề phòng kéo hàng ngàn dòng thì tôi có vd. Application.ScreenUpdating = False / True.

Khi người ta kéo như thế thì Target là nhiều cell nên chắc chắn có lỗi ở dòng

Mã:

.Offset(0, 1).Resize(1, 5) = ConvertDate2ABC(CLng(Val(Target.Value2)))

Target.Value2 là cả một mảng giá trị nên CLng(Val(Target.Value2)) sẽ có lỗi.

LamNA · 29/4/18

tle2003 đã viết:
Thêm phần Thứ vào code của batman1 , chắc lần này được rồi nghe.

Dạ em cám ơn, em đã thực hiện được rồi ạ

LamNA · 29/4/18

LamNA đã viết:
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

befaint · 29/4/18

batman1 đã viết:
Không đơn giản thế đâu.
1. Theo lôgíc của tôi thì khi nhập ngày tháng ở A thì trong 5 cột tiếp theo sẽ có kết quả. Vậy khi xóa A thì 5 cột kia cũng phải rỗng. Nhưng trong code của bạn khi xóa A thì dDate = 0, như vậy trong 5 cột vẫn có dữ liệu - của những năm tháng xa xôi.

2. Người ta có

Người ta không nói kéo xuống bao nhiêu nên để đề phòng kéo hàng ngàn dòng thì tôi có vd. Application.ScreenUpdating = False / True.

Khi người ta kéo như thế thì Target là nhiều cell nên chắc chắn có lỗi ở dòng

Mã:

.Offset(0, 1).Resize(1, 5) = ConvertDate2ABC(CLng(Val(Target.Value2)))

Target.Value2 là cả một mảng giá trị nên CLng(Val(Target.Value2)) sẽ có 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!

LamNA · 29/4/18

befaint đã viết:
(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!

Có thể giúp em ở bài 21 không anh?

batman1 · 30/4/18

Đây không phải procedure bình thường để bạn khai báo tên bất kỳ.
Private Sub Worksheet_Change() có nghĩa là đây là procedure phục vụ sự kiện "thay đổi" trên sheet, và nó sẽ được gọi khi có sự thay đổi nào đó trên sheet.

Bạn click để mở combobox ở bên phải thì thấy có dòng "Change". Tức đối tượng sheet có event procedure với tên là Change. Làm gì có event Change1? Nếu bạn có Private Sub Worksheet_Change1() thì lúc đó nó được coi là procedure bình thường có tên là Worksheet_Change1. Nó không phải là event procedure. Thế thôi. Procedure ấy sẽ vô dụng vì không được gọi khi có sự thay đổi trên sheet.

Nếu cần thì gộp 2 thành 1. Tôi chỉ gộp cho bạn thôi chứ không sửa, không làm tối ưu code đầu. Bạn tự là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

batman1 · 30/4/18

befaint đã viết:
(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ờ thích những câu hỏi như thế này. Khi đã biết cần phải xét những trường hợp như thế nào thì mỗi người tự kiểm tra thôi chứ sao lại phải hỏi?

LamNA · 30/4/18

batman1 đã viết:
Đây không phải procedure bình thường để bạn khai báo tên bất kỳ.
Private Sub Worksheet_Change() có nghĩa là đây là procedure phục vụ sự kiện "thay đổi" trên sheet, và nó sẽ được gọi khi có sự thay đổi nào đó trên sheet.

Bạn click để mở combobox ở bên phải thì thấy có dòng "Change". Tức đối tượng sheet có event procedure với tên là Change. Làm gì có event Change1? Nếu bạn có Private Sub Worksheet_Change1() thì lúc đó nó được coi là procedure bình thường có tên là Worksheet_Change1. Nó không phải là event procedure. Thế thôi. Procedure ấy sẽ vô dụng vì không được gọi khi có sự thay đổi trên sheet.

Nếu cần thì gộp 2 thành 1. Tôi chỉ gộp cho bạn thôi chứ không sửa, không làm tối ưu code đầu. Bạn tự là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

batman1 · 30/4/18

Thực ra cũng tùy. Thực ra có thể viết không có 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 bạn thay đổi chỉ cột D hoặc M thì code trước và code này như nhau. Nhưng nếu bạn dán 1 lần vào cả 2 cột D và M thì có sự khác nhau. Code trước chỉ thực hiện phần trước ELSE. Code sau thì thực hiện cả cho sự thay đổi trong cột D và cả cho sự thay đổi trong cột M. Do bạn chỉ tung code lên mà không giải thích gì thêm nên tôi gộp với ELSE. Nhưng phải ý thức được là có trường hợp, dù là lý thuyết, khi bạn dán vào đồng thời 2 cột D và M. Nếu lúc đó bạn muốn xử lý cả 2 hậu quả thì phải dùng code không có ELSE ở trên.

LamNA · 30/4/18

batman1 đã viết:
Thực ra cũng tùy. Thực ra có thể viết không có 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 bạn thay đổi chỉ cột D hoặc M thì code trước và code này như nhau. Nhưng nếu bạn dán 1 lần vào cả 2 cột D và M thì có sự khác nhau. Code trước chỉ thực hiện phần trước ELSE. Code sau thì thực hiện cả cho sự thay đổi trong cột D và cả cho sự thay đổi trong cột M. Do bạn chỉ tung code lên mà không giải thích gì thêm nên tôi gộp với ELSE. Nhưng phải ý thức được là có trường hợp, dù là lý thuyết, khi bạn dán vào đồng thời 2 cột D và M. Nếu lúc đó bạn muốn xử lý cả 2 hậu quả thì phải dùng code không có 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

batman1 · 30/4/18

LamNA đã viết:
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 là bạn xử lý sự thay đổi ở cột D, M. Ý tôi nói là có sự khác biệt khi chỉ thay đổi D hoặc M, và lúc khác lại D hoặc M và trường hợp khi bạn đồng thời thay đổi cả D và 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 tại tôi đang phải dịch một bản tài liệu sang tiếng Việt. Chưa biết khi nào xong.

Mà theo nội qui thì hình như mỗi chủ đề chỉ là một vấn đề. Có thể bạn phải lập chủ đề khác.

batman1 · 30/4/18

Thế trong cột Y có công thức hay dữ liệu nhập bằng tay, bằng máy?
Nếu không phải công thức thì:
1. Xóa toàn bộ công thức trong cột AQ.
2. Trong Worksheet_Change thêm đoạ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

Cách thêm thì tôi đã giải thích rồi, bạn tự chọn.

Có thể thay đoạn

Mã:

Select Case rng.Value / 10 ^ 6
...
End Select

bằng Application.VLookup. Bạn tự đọc, tự nghiên cứu.

Vì code vào giữa chừng cuộc chơi nên nó không thể phản ứng với những dữ liệu đã có trong cột Y - sự kiện Change đã sảy ra hôm qua, tuần trước. Vì thế nếu đã có dữ liệu trong cột Y thì làm 1 lần các thao tác: Chọn toàn bộ dữ liệu cột Y -> nhấn Ctrl + C -> nhấn Ctrl + V (mục đích để tạo ra sự kiện Change cho những dữ liệu đã có)

Xóa dữ liệu cột Y thì cột AQ sẽ rỗng.

LamNA · 30/4/18

batman1 đã viết:
Thế trong cột Y có công thức hay dữ liệu nhập bằng tay, bằng máy?
Nếu không phải công thức thì:
1. Xóa toàn bộ công thức trong cột AQ.
2. Trong Worksheet_Change thêm đoạ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

Cách thêm thì tôi đã giải thích rồi, bạn tự chọn.

Có thể thay đoạn

Mã:

Select Case rng.Value / 10 ^ 6 ... End Select

bằng Application.VLookup. Bạn tự đọc, tự nghiên cứu.

Vì code vào giữa chừng cuộc chơi nên nó không thể phản ứng với những dữ liệu đã có trong cột Y - sự kiện Change đã sảy ra hôm qua, tuần trước. Vì thế nếu đã có dữ liệu trong cột Y thì làm 1 lần các thao tác: Chọn toàn bộ dữ liệu cột Y -> nhấn Ctrl + C -> nhấn Ctrl + V (mục đích để tạo ra sự kiện Change cho những dữ liệu đã có)

Xóa dữ liệu cột Y thì cột AQ sẽ 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

LamNA · 30/4/18

batman1 đã viết:
Thế trong cột Y có công thức hay dữ liệu nhập bằng tay, bằng máy?
Nếu không phải công thức thì:
1. Xóa toàn bộ công thức trong cột AQ.
2. Trong Worksheet_Change thêm đoạ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

Cách thêm thì tôi đã giải thích rồi, bạn tự chọn.

Có thể thay đoạn

Mã:

Select Case rng.Value / 10 ^ 6 ... End Select

bằng Application.VLookup. Bạn tự đọc, tự nghiên cứu.

Vì code vào giữa chừng cuộc chơi nên nó không thể phản ứng với những dữ liệu đã có trong cột Y - sự kiện Change đã sảy ra hôm qua, tuần trước. Vì thế nếu đã có dữ liệu trong cột Y thì làm 1 lần các thao tác: Chọn toàn bộ dữ liệu cột Y -> nhấn Ctrl + C -> nhấn Ctrl + V (mục đích để tạo ra sự kiện Change cho những dữ liệu đã có)

Xóa dữ liệu cột Y thì cột AQ sẽ 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

LamNA · 30/4/18

batman1 đã viết:
Thế trong cột Y có công thức hay dữ liệu nhập bằng tay, bằng máy?
Nếu không phải công thức thì:
1. Xóa toàn bộ công thức trong cột AQ.
2. Trong Worksheet_Change thêm đoạ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

Cách thêm thì tôi đã giải thích rồi, bạn tự chọn.

Có thể thay đoạn

Mã:

Select Case rng.Value / 10 ^ 6 ... End Select

bằng Application.VLookup. Bạn tự đọc, tự nghiên cứu.

Vì code vào giữa chừng cuộc chơi nên nó không thể phản ứng với những dữ liệu đã có trong cột Y - sự kiện Change đã sảy ra hôm qua, tuần trước. Vì thế nếu đã có dữ liệu trong cột Y thì làm 1 lần các thao tác: Chọn toàn bộ dữ liệu cột Y -> nhấn Ctrl + C -> nhấn Ctrl + V (mục đích để tạo ra sự kiện Change cho những dữ liệu đã có)

Xóa dữ liệu cột Y thì cột AQ sẽ 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

batman1 · 30/4/18

LamNA đã viết:
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 đã nói với bạn là tùy vào trường hợp mà dùng. Có ai bắt dùng ELSE đâu?
Mà bạn hãy mô tả cái "đổ dữ liệu copy vào". Đổ thế nào, bằng cái gì, từ đâu tới đâu.
------
Mà nên giải thích kỹ cách hoạt động của tập tin. Trong Change bạn dùng dic và aResult. Chả biết dic được tạo ở đâu, khi nào. aResult mặt mũi thế nào. Vlookup_DATA_SP nằm ở đâu, làm những gì, việc làm có thay đổi gì trên sheet không. Vì lúc đó code đã tạo ra sự kiện Change ...
Không phải ai cũng thích mất thời gian, thích sửa đi sửa lại. Viết từng khúc riêng biệt để rồi chắp vá lại với nhau.

LamNA · 30/4/18

batman1 đã viết:
Tôi đã nói với bạn là tùy vào trường hợp mà dùng. Có ai bắt dùng ELSE đâu?
Mà bạn hãy mô tả cái "đổ dữ liệu copy vào". Đổ thế nào, bằng cái gì, từ đâu tới đâu.
------
Mà nên giải thích kỹ cách hoạt động của tập tin. Trong Change bạn dùng dic và aResult. Chả biết dic được tạo ở đâu, khi nào. aResult mặt mũi thế nào. Vlookup_DATA_SP nằm ở đâu, làm những gì, việc làm có thay đổi gì trên sheet không. Vì lúc đó code đã tạo ra sự kiện Change ...
Không phải ai cũng thích mất thời gian, thích sửa đi sửa lại. Viết từng khúc riêng biệt để rồi chắp vá lạ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

batman1 · 30/4/18

LamNA đã viết:
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 có viết

Mà bạn hãy mô tả cái "đổ dữ liệu copy vào". Đổ thế nào, bằng cái gì, từ đâu tới đâu.

Nhưng bạn không trả lời.

Thôi, tôi sửa thế này. Bạ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

LamNA · 30/4/18

batman1 đã viết:

Tôi có viết

Nhưng bạn không trả lời.

Thôi, tôi sửa thế này. Bạ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

batman1 · 30/4/18

Thế bạn đã thử code tôi vừa sửa không?

LamNA · 30/4/18

batman1 đã viết:
Thế bạn đã thử code tôi vừa sửa không?

Dạ em đã thử và chạy tốt rồi,
Anh có giúp em thêm phần tô vàng như file đính kèm nhe
Em cám ơn anh nhiều

batman1 · 30/4/18

Code đòi hỏi cột M phải là ngày tháng chứ không phải trông giống ngày tháng. Hiện cột D không chứa ngày tháng theo đúng triết lý của Excel. D chỉ chứa chuỗi thôi. Tự bạn nhập lại hoặc nhờ ai đó sửa lại. Tôi không muốn mất công chỉ vì ai đó cẩu thả.

Tôi viết lại code vì thấy bạn phục vụ tới 600000 dòng, và có chuyện "đổ" dữ liệu vào sheet. Nếu đổ mỗi lần hàng ngàn, chục ngàn dòng thì code cũ chạ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 gì thêm thì nên mở chủ đề mới nhé.

LamNA · 30/4/18

batman1 đã viết:

Code đòi hỏi cột M phải là ngày tháng chứ không phải trông giống ngày tháng. Hiện cột D không chứa ngày tháng theo đúng triết lý của Excel. D chỉ chứa chuỗi thôi. Tự bạn nhập lại hoặc nhờ ai đó sửa lại. Tôi không muốn mất công chỉ vì ai đó cẩu thả.

Tôi viết lại code vì thấy bạn phục vụ tới 600000 dòng, và có chuyện "đổ" dữ liệu vào sheet. Nếu đổ mỗi lần hàng ngàn, chục ngàn dòng thì code cũ chạ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 gì thêm thì nên mở chủ đề mới nhé.

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ẻ

batman1 · 1/5/18

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.

Ý bạn muốn nói là công thức tuy nặng nhưng tính nhanh hơn?

Máy của tôi 17 năm tuổi, đĩa cứng 38GB (C có 10GB), 2 GHz, RAM 1GB nếu đổ xuống sheet 600 000 dòng dữ liệu từ A đến AM thì mất khoảng 240 giây. Nếu máy của bạn mới thì có lẽ chỉ khoảng 30 đến 60 giây.
Với công thức thì chưa bàn tới nặng hay nhẹ tập tin mà nếu bạn đổ 600 000 dòng dữ liệu xuống sheet thì các công thức kia cũng khó mà tính toán nhanh hơn.

batman1 · 1/5/18

Khi viết lại đoạn code đầu của bạn tôi đã bỏ xót việc xóa dữ liệu của cột đầu ở mảng kết quả
Hã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

thà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 dòng

Mã:

Else
    result(i, 1) = Empty

----------------
Bạn cũng có thể dùng phiên bản mới dùng ít bộ nhớ hơn - mảng làm việc nhỏ 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

LamNA · 1/5/18

batman1 đã viết:

Khi viết lại đoạn code đầu của bạn tôi đã bỏ xót việc xóa dữ liệu của cột đầu ở mảng kết quả
Hã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

thà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 dòng

Mã:

Else
    result(i, 1) = Empty

----------------
Bạn cũng có thể dùng phiên bản mới dùng ít bộ nhớ hơn - mảng làm việc nhỏ 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

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

batman1 · 1/5/18

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

Do bạn không nói nên tôi làm theo công thức thôi. Công thức không trả về chuỗi rỗng khi xóa dữ liệu nguồn

Mã:

=N(COUNTIFS($P$3:P3;P3;$M$3:M3;M3)=1)

nên tôi làm đúng theo như thế.

Bạn đợi nhé. Hôm nay là ngày lễ mà

batman1 · 1/5/18

1. Chỉ cần hoặc M hoặc P rỗng thì cột AY rỗng. Tức không cần đồng thời M và P rỗng. Tất nhiên theo lôgíc thì khi M rỗng thì P cũng phải rỗng. Nhưng đây là việc của người "đổ dữ liệu vào sheet"
2. Chỉ cần hoặc C hoặc M rỗng thì cột AZ rỗng. Tức không cần đồng thời C và M rỗng. Tất nhiên theo lôgíc thì khi C rỗng thì M cũng phải rỗng. Nhưng đây là việc của người "đổ dữ liệu và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

LamNA · 1/5/18

batman1 đã viết:

1. Chỉ cần hoặc M hoặc P rỗng thì cột AY rỗng. Tức không cần đồng thời M và P rỗng. Tất nhiên theo lôgíc thì khi M rỗng thì P cũng phải rỗng. Nhưng đây là việc của người "đổ dữ liệu vào sheet"
2. Chỉ cần hoặc C hoặc M rỗng thì cột AZ rỗng. Tức không cần đồng thời C và M rỗng. Tất nhiên theo lôgíc thì khi C rỗng thì M cũng phải rỗng. Nhưng đây là việc của người "đổ dữ liệu và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

Quá tuyệt vời
Em cám ơn anh nhe

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

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

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

File đính kèm

Thành viên hoạt động

Thành viên gắn bó

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

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

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

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

Thành viên hoạt động

File đính kèm

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

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

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

File đính kèm

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

File đính kèm

|||||||||||||

Thành viên gạo cội

Thành viên hoạt động

File đính kèm

|||||||||||||

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

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

Thành viên gạo cội

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

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

|||||||||||||

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

Thành viên gạo cội

Thành viên gạo cội

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

Thành viên gạo cội

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

File đính kèm

Thành viên gạo cội

Thành viên gạo cội

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

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

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

Thành viên gạo cội

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

File đính kèm

Thành viên gạo cội

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

Thành viên gạo cội

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

File đính kèm

Thành viên gạo cội

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

Thành viên gạo cội

Thành viên gạo cội

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

Thành viên gạo cội

Thành viên gạo cội

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

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