Lọc danh sách duy nhất cho từng cột riêng rẽ (1 người xem)

hdg2318 · 18/9/15

Các bác giúp e vụ loc này với.

E có 1 file với hơn 100 cột, mỗi cột chứa nhiều dữ liệu mã khác nhau (cố thể trùng). Giờ e cần lọc ra 1 danh sách mã duy nhất cho từng cột (danh sách này được đặt bên dưới từng cột chứa dữ liệu ) để lấy dữ liệu tham chiếu cho các công việc khác.

Các cột này được update hàng ngày nên dùng Advance Filter là không khả thi.

E cũng tìm hiểu trên GPE, áp dụng 1 số cách của các bác như dùng c.thức hay hàm tự tạo cho mảng. Với số lượng cột ít thì ok, nhưng khi kéo c.thức cho hơn 100 cột thì oải quá, và gây chậm nữa.

Bác nào có cao kiến gì xin giúp e với ạ. E gửi kèm theo file mẫu với 4 cột thôi, thực tế file của e có 15 sheet, mỗi sheet có khoảng 145 cột, mỗi cột có khoảng 80 ô dữ liệu ( số ô này là fix, dữ liệu có thể kín hoặc ko kín cả 80 ô).

hdg2318 · 18/9/15

Đây là file mẫu của e ạ.

khuongvietphong · 18/9/15

hdg2318 đã viết:
Đây là file mẫu của e ạ.

CT này tại ô B16 : =IFERROR(INDEX(B$4:B$11,MATCH(0,COUNTIF(B$15:B15,B$4:B$11),0)),"")

Sau đó bạn chỉ việc Fill xuống Fill sang !

Nguyễn Duy Tuân · 18/9/15

Dùng Add-in A-Tools là giải pháp cho tốc độ chạy nhanh với file Excel có nhiều dữ liệu. Có thể lọc dữ liệu nhiều điều kiện rất dễ và linh hoạt. Lấy danh sách duy nhất đơn giản là công thức:

=BS_SQL("SELECT DISTINCT TENCOT FROM NGUONDULIEU")

Bạn lên youtube xem cách làm Add-in A-Tools:

[video=youtube;ZwJOWvWCP3o]https://www.youtube.com/watch?v=ZwJOWvWCP3o[/video]

doveandrose · 18/9/15

Nguyễn Duy Tuân đã viết:
Dùng Add-in A-Tools là giải pháp cho tốc độ chạy nhanh với file Excel có nhiều dữ liệu. Có thể lọc dữ liệu nhiều điều kiện rất dễ và linh hoạt. Lấy danh sách duy nhất đơn giản là công thức:

=BS_SQL("SELECT DISTINCT TENCOT FROM NGUONDULIEU")

âm thanh nhỏ quá anh ơi hỏng nghe thấy gì trỏng

hdg2318 · 18/9/15

Sao mình paste công thức của bạn vào mà nó trắng trơn, ko có kết quả hiện ra là sao nhỉ? Bạn xem lại giúp mình nhé. Và dữ liệu của mình ko phải chỉ có 4 cột bạn nhé.

khuongvietphong · 18/9/15

hdg2318 đã viết:
Sao mình paste công thức của bạn vào mà nó trắng trơn, ko có kết quả hiện ra là sao nhỉ? Bạn xem lại giúp mình nhé. Và dữ liệu của mình ko phải chỉ có 4 cột bạn nhé.

Trong 1 đề tài có nhiều người tham gia ,khi bạn trả lời phải kèm cả trích dẫn nữa thì người ta mới biết bạn nói chuyện với ai.

Nếu là CT của mình thì
Bạn phải nhấn CTRL+SHIFT+ENTER mới ra kết quả nhé

hdg2318 · 18/9/15

khuongvietphong đã viết:
Bạn phải nhấn CTRL+SHIFT+ENTER mới ra kết quả nhé

vẫn ko đưuọc bạn ơi, nó chỉ hiện ra 1 kết quả cho tất cả các ô trong mảng.

khuongvietphong · 18/9/15

hdg2318 đã viết:
vẫn ko đưuọc bạn ơi, nó chỉ hiện ra 1 kết quả cho tất cả các ô trong mảng.

Mình thử thấy vẫn ra bình thường mà, bạn gửi File bạn làm lên thử coi

hdg2318 · 18/9/15

khuongvietphong đã viết:
Mình thử thấy vẫn ra bình thường mà, bạn gửi File bạn làm lên thử coi

Hi, thanks bạn.

Mình thử lại thì ok rồi, nhưng khi áp vào file của mình thì khi nhập liệu bị chậm, độ trễ khoảng 3-4 giây cho 1 lần nhập. Nếu máy yếu có thể lâu hơn.

có cách nào khả quan hơn không nhỉ?

doatmenhhon · 18/9/15

Sao bạn không tìm cách mỗi lần nhập liệu nếu trùng với giá trị cột có sẵn thì ra thông báo đã nhập rồi hơn là cách nhập rồi lại tìm trùng để xóa đi. . Trên diễn đàn có nhiều giải pháp về vấn đề này bạn thử search xem

hdg2318 · 18/9/15

doatmenhhon đã viết:
Sao bạn không tìm cách mỗi lần nhập liệu nếu trùng với giá trị cột có sẵn thì ra thông báo đã nhập rồi hơn là cách nhập rồi lại tìm trùng để xóa đi. . Trên diễn đàn có nhiều giải pháp về vấn đề này bạn thử search xem

Không được bạn ơi. Mỗi ô dữ liệu tham chiếu theo cột là ngày, tham chiếu theo dòng là khách hàng. Thế nên không thể không cho phép nhập trùng được.

doveandrose · 18/9/15

doatmenhhon đã viết:
Sao bạn không tìm cách mỗi lần nhập liệu nếu trùng với giá trị cột có sẵn thì ra thông báo đã nhập rồi hơn là cách nhập rồi lại tìm trùng để xóa đi. . Trên diễn đàn có nhiều giải pháp về vấn đề này bạn thử search xem

thật tức cười . bảng nhập liệu cũng có khi cần phải nhập trùng chứ

hdg2318 đã viết:
E có 1 file với hơn 100 cột, mỗi cột chứa nhiều dữ liệu mã khác nhau (cố thể trùng). Giờ e cần lọc ra 1 danh sách mã duy nhất cho từng cột (danh sách này được đặt bên dưới từng cột chứa dữ liệu ) để lấy dữ liệu tham chiếu cho các công việc khác.

nhu cầu công việc là lấy ra danh sách không trùng để đi làm việc khác chứ không phải là khống chế đầu vào không cho nhập trùng
bạn nên luyện thêm kỹ năng đọc hiểu người khác muốn gì trước khi tham gia giúp đỡ người khác . nó giúp ích cho cả bạn và người cần giúp đấy

doatmenhhon · 18/9/15

doveandrose đã viết:
thật tức cười . bảng nhập liệu cũng có khi cần phải nhập trùng chứ

nhu cầu công việc là lấy ra danh sách không trùng để đi làm việc khác chứ không phải là khống chế đầu vào không cho nhập trùng
bạn nên luyện thêm kỹ năng đọc hiểu người khác muốn gì trước khi tham gia giúp đỡ người khác . nó giúp ích cho cả bạn và người cần giúp đấy

Tôi chỉ nói là thông báo chứ không bảo là không cho phép nhập vào. Nếu lúc đó ta có một cách đánh dấu “nho nhỏ” để rồi khi cần sau 1 cái click chuột ta sẽ cho ra 1 bảng khác như ý liệu có phải là ý tưởng rất sáng tạo???

doveandrose · 18/9/15

doatmenhhon đã viết:
Tôi chỉ nói là thông báo chứ không bảo là không cho phép nhập vào. Nếu lúc đó ta có một cách đánh dấu “nho nhỏ” để rồi khi cần sau 1 cái click chuột ta sẽ cho ra 1 bảng khác như ý liệu có phải là ý tưởng rất sáng tạo???

ờ . cực kỳ sáng tạo ! nhập liệu mà cứ trùng phát là có bảng thông báo hiện lên . 10 điểm cho sáng tạo .( cười không nhặt được hàm)

doatmenhhon · 18/9/15

doveandrose đã viết:
ờ . cực kỳ sáng tạo ! nhập liệu mà cứ trùng phát là có bảng thông báo hiện lên . 10 điểm cho sáng tạo .( cười không nhặt được hàm)

Không gì là không thể đừng khô héo mình cùng những công thức cũ kỹ

Nguyễn Duy Tuân · 18/9/15

Dùng A-Tools sẽ đạt tốc độ nhanh nhất. Các bạn cứ thử nghiệm xem.

ndu96081631 · 18/9/15

hdg2318 đã viết:
có cách nào khả quan hơn không nhỉ?

Khả quan nhất là viết code VBA, bạn có thích không?

hdg2318 · 18/9/15

ndu96081631 đã viết:
Khả quan nhất là viết code VBA, bạn có thích không?

Vâng, thầy giúp em với ạ.

ndu96081631 · 18/9/15

hdg2318 đã viết:
Vâng, thầy giúp em với ạ.

Vậy thì bạn vui lòng đưa dữ liệu gần giống thật nhất lên đây, nêu rõ kết quả lọc đặt tại đâu nhé!
Bởi với dữ liệu đơn sơ như ở bài 2 thì tôi tin chắc rằng sau khi viết code xong, bạn ráp vào file thật không được lại chạy lên hỏi tiếp cho mà coi

doatmenhhon · 18/9/15

Thầy ndu code của em vẫn còn sai tung tóe. Thầy thử xem có được ko?

khuongvietphong · 18/9/15

doatmenhhon đã viết:
Thầy ndu code của em vẫn còn sai tung tóe. Thầy thử xem có được ko?

Bạn xem lại qua chút . Code này khi bấm run lần đầu cho kết quả đúng, bấm lần tiếp theo dữ liệu bị mất rồi cứ bấm là mất dần mất dần, đến khi chi còn lại hàng đầu tiên

ndu96081631 · 18/9/15

doatmenhhon đã viết:
Thầy ndu code của em vẫn còn sai tung tóe. Thầy thử xem có được ko?

Sửa code của bạn:

Mã:

Sub Button5_Click()
  Dim a, tmp
  Dim i As Long, ii As Long, n As Long
  Dim rng As Range, dic As Object
  Set rng = ActiveSheet.UsedRange
  With rng
    For i = 1 To .Columns.Count
      a = .Columns(i).Value
      If IsArray(a) Then
        [COLOR=#ff0000]Set dic = CreateObject("Scripting.Dictionary")
        dic.CompareMode = vbTextCompare[/COLOR]
        ReDim b(1 To UBound(a), 1 To 1)
       [COLOR=#ff0000] n = 0[/COLOR]
        For ii = 1 To UBound(a)
          tmp = CStr(a(ii, 1))
          If Len(tmp) Then
            If Not dic.Exists(tmp) Then
              n = n + 1
              dic.Add tmp, n
              b(n, 1) = tmp
            End If
          End If
        Next
        If n Then .Columns(i).Value = b
      End If
    Next
  End With
End Sub

hdg2318 · 18/9/15

ndu96081631 đã viết:
Vậy thì bạn vui lòng đưa dữ liệu gần giống thật nhất lên đây, nêu rõ kết quả lọc đặt tại đâu nhé!
Bởi với dữ liệu đơn sơ như ở bài 2 thì tôi tin chắc rằng sau khi viết code xong, bạn ráp vào file thật không được lại chạy lên hỏi tiếp cho mà coi

Em gửi file mẫu đây ạ, dữ liệu không chính xác nhưng kiểu dữ liệu thì đúng ạ.
Thầy xem giúp em với ạ.

doatmenhhon · 18/9/15

Em cảm ơn thầy file chuẩn rồi ạ. Em thật sự xúc động

Kiều Mạnh · 18/9/15

ndu96081631 đã viết:

Sửa code của bạn:

Mã:

Sub Button5_Click()
  Dim a, tmp
  Dim i As Long, ii As Long, n As Long
  Dim rng As Range, dic As Object
  Set rng = ActiveSheet.UsedRange
  With rng
    For i = 1 To .Columns.Count
      a = .Columns(i).Value
      If IsArray(a) Then
        [COLOR=#ff0000]Set dic = CreateObject("Scripting.Dictionary")
        dic.CompareMode = vbTextCompare[/COLOR]
        ReDim b(1 To UBound(a), 1 To 1)
       [COLOR=#ff0000] n = 0[/COLOR]
        For ii = 1 To UBound(a)
          tmp = CStr(a(ii, 1))
          If Len(tmp) Then
            If Not dic.Exists(tmp) Then
              n = n + 1
              dic.Add tmp, n
              b(n, 1) = tmp
            End If
          End If
        Next
        If n Then .Columns(i).Value = b
      End If
    Next
  End With
End Sub

Em mới thử có bao nhiêu cột được hết
dòng sau khả năng của em chưa hiểu tới...Nếu được xin anh chỉ dùm

dic.CompareMode = vbTextCompare

Em cảm ơn

ndu96081631 · 18/9/15

hdg2318 đã viết:
Em gửi file mẫu đây ạ, dữ liệu không chính xác nhưng kiểu dữ liệu thì đúng ạ.
Thầy xem giúp em với ạ.

Thấy chưa! Dữ liệu mới đưa lên chẳng giống chút nào so với yêu cầu ban đầu
Bài này mà làm cũng không phải chuyện dễ đâu à nghen
Mời các cao thủ thử sức
-----------------------
Nói thêm: Trong file của bạn, tại cell B70 tôi thấy bạn ghi:

Lọc hết Cod và Qty Exp của ngày thường

Nhưng khu vực lọc ra kết quả bạn cho sẵn 10 dòng. Sao bạn biết chắc kết quả chỉ 10 dòng? Lỡ kết quả 20 dòng thì sao?

hdg2318 · 18/9/15

ndu96081631 đã viết:
-----------------------
Nói thêm: Trong file của bạn, tại cell B70 tôi thấy bạn ghi:

Nhưng khu vực lọc ra kết quả bạn cho sẵn 10 dòng. Sao bạn biết chắc kết quả chỉ 10 dòng? Lỡ kết quả 20 dòng thì sao?

Vâng, theo đặc thù công việc thì số dòng kết quả chỉ chừng đó là đủ rồi thầy ạ. Mỗi cá nhân và mỗi bộ phận đảm nhận một số lượng mã, và các mã này lại có thể được phân loại ra theo các sheet nữa, nên 10 dòng là ok rồi ạ.

doveandrose · 19/9/15

ndu96081631 đã viết:
Thấy chưa! Dữ liệu mới đưa lên chẳng giống chút nào so với yêu cầu ban đầu
Bài này mà làm cũng không phải chuyện dễ đâu à nghen
Mời các cao thủ thử sức
-----------------------
Nói thêm: Trong file của bạn, tại cell B70 tôi thấy bạn ghi:

Nhưng khu vực lọc ra kết quả bạn cho sẵn 10 dòng. Sao bạn biết chắc kết quả chỉ 10 dòng? Lỡ kết quả 20 dòng thì sao?

tính đi rồi mà nghe thầy NDU quảng cáo dữ quá , quay lại đu dây tí . hi hi

Mã:

Public Sub hello()
Dim rgName As String, arr As Variant, Dic As Object, tempKey As Variant
Dim r As Long, c As Long, preDay As Byte, dArr As Variant, arRow(1 To 4) As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet18
    rgName = .Range("B10").CurrentRegion.Address
    arr = .Range("C10" & Mid(rgName, InStr(rgName, ":"))).Value
    ReDim dArr(1 To 40, 1 To UBound(arr, 2) - 1)
    For c = 2 To UBound(arr, 2) Step 1
        arr(1, c) = IIf(Len(arr(1, c)) > 0, Weekday(arr(1, c), vbMonday), preDay)
        preDay = arr(1, c)
        arRow(1) = 0: arRow(2) = 10: arRow(3) = 20: arRow(4) = 30
        Dic.RemoveAll
        For r = 3 To UBound(arr) Step 1
            If Len(arr(r, c)) > 0 Then
                tempKey = arr(r, 1) & ";" & arr(r, c)
                If Not Dic.exists(tempKey) Then
                    Dic(tempKey) = 1
                    If arr(r, 1) = "Exp" Then
                        If arr(1, c) < 6 Then
                            arRow(1) = WorksheetFunction.Min(arRow(1) + 1, 10)
                            dArr(arRow(1), c - 1) = arr(r, c)
                        End If
                    ElseIf arr(r, 1) = "Imp" Then
                        If arr(1, c) < 6 Then
                            arRow(2) = WorksheetFunction.Min(arRow(2) + 1, 20)
                            dArr(arRow(2), c - 1) = arr(r, c)
                        ElseIf arr(1, c) = 6 Then
                            arRow(3) = WorksheetFunction.Min(arRow(3) + 1, 30)
                            dArr(arRow(3), c - 1) = arr(r, c)
                        Else
                            arRow(4) = WorksheetFunction.Min(arRow(4) + 1, 40)
                            dArr(arRow(4), c - 1) = arr(r, c)
                        End If
                    End If
                End If
            End If
        Next
    Next
    .Range("D" & .Range("D" & Mid(rgName, InStrRev(rgName, "$") + 1)).End(xlDown).Row + 1) _
                .Resize(40, UBound(dArr, 2)).Value = dArr
End With
End Sub

ndu96081631 · 19/9/15

kieu manh đã viết:
=
dòng sau khả năng của em chưa hiểu tới...Nếu được xin anh chỉ dùm

dic.CompareMode = vbTextCompare

Em cảm ơn

Không biết có thể thí nghiệm:

Mã:

Sub Test_1()
  Dim dic As Object
  Set dic = CreateObject("Scripting.Dictionary")
  dic.Add "a", ""
  dic.Add "A", ""
End Sub

Mã:

Sub Test_2()
  Dim dic As Object
  Set dic = CreateObject("Scripting.Dictionary")
  [COLOR=#ff0000]dic.CompareMode = vbTextCompare[/COLOR]
  dic.Add "a", ""
  dic.Add "A", ""
End Sub

Test_2 có vbTextCompare và Test_1 không có. Chạy thử 2 Sub và so sánh. Đọc kỹ thông báo lỗi nếu có
Nói thêm: Sub Test_1 không ghi Compare kiểu nào thì ngầm hiểu là dic.CompareMode = vbBinaryCompare

hdg2318 · 19/9/15

doveandrose đã viết:

tính đi rồi mà nghe thầy NDU quảng cáo dữ quá , quay lại đu dây tí . hi hi

Mã:

Public Sub hello()
Dim rgName As String, arr As Variant, Dic As Object, tempKey As Variant
Dim r As Long, c As Long, preDay As Byte, dArr As Variant, arRow(1 To 4) As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet18
    rgName = .Range("B10").CurrentRegion.Address
    arr = .Range("C10" & Mid(rgName, InStr(rgName, ":"))).Value
    ReDim dArr(1 To 40, 1 To UBound(arr, 2) - 1)
    For c = 2 To UBound(arr, 2) Step 1
        arr(1, c) = IIf(Len(arr(1, c)) > 0, Weekday(arr(1, c), vbMonday), preDay)
        preDay = arr(1, c)
        arRow(1) = 0: arRow(2) = 10: arRow(3) = 20: arRow(4) = 30
        Dic.RemoveAll
        For r = 3 To UBound(arr) Step 1
            If Len(arr(r, c)) > 0 Then
                tempKey = arr(r, 1) & ";" & arr(r, c)
                If Not Dic.exists(tempKey) Then
                    Dic(tempKey) = 1
                    If arr(r, 1) = "Exp" Then
                        If arr(1, c) < 6 Then
                            arRow(1) = WorksheetFunction.Min(arRow(1) + 1, 10)
                            dArr(arRow(1), c - 1) = arr(r, c)
                        End If
                    ElseIf arr(r, 1) = "Imp" Then
                        If arr(1, c) < 6 Then
                            arRow(2) = WorksheetFunction.Min(arRow(2) + 1, 20)
                            dArr(arRow(2), c - 1) = arr(r, c)
                        ElseIf arr(1, c) = 6 Then
                            arRow(3) = WorksheetFunction.Min(arRow(3) + 1, 30)
                            dArr(arRow(3), c - 1) = arr(r, c)
                        Else
                            arRow(4) = WorksheetFunction.Min(arRow(4) + 1, 40)
                            dArr(arRow(4), c - 1) = arr(r, c)
                        End If
                    End If
                End If
            End If
        Next
    Next
    .Range("D" & .Range("D" & Mid(rgName, InStrRev(rgName, "$") + 1)).End(xlDown).Row + 1) _
                .Resize(40, UBound(dArr, 2)).Value = dArr
End With
End Sub

Thanks bác, chuẩn rồi bác ơi. Nhưng e có thắc mắc chút là sao nó lại có cái dòng ô mang giá trị 118 ở bên cột Cod như hình thế ah? Bác xem bỏ giúp em với.

E hơi tham lam chút :
Bác có thể giúp e làm cho cái macro nó tụ chạy mà ko cần phải ấn Alt+F8 -> Run không ạ?

Bác hộ e chỉnh sột Qty ko phải là list duy nhất mà là total của từng mã ở cột Cod bên cạnh.

E thấy code của bác chạy rất nhanh. Các bác giúp e với nhé. Cảm ơn các bác nhiều ạ.

doveandrose · 19/9/15

hdg2318 đã viết:
Thanks bác, chuẩn rồi bác ơi. Nhưng e có thắc mắc chút là sao nó lại có cái dòng ô mang giá trị 118 ở bên cột Cod như hình thế ah? Bác xem bỏ giúp em với.
View attachment 147440
E hơi tham lam chút :
Bác có thể giúp e làm cho cái macro nó tụ chạy mà ko cần phải ấn Alt+F8 -> Run không ạ?

Bác hộ e chỉnh sột Qty ko phải là list duy nhất mà là total của từng mã ở cột Cod bên cạnh.

E thấy code của bác chạy rất nhanh. Các bác giúp e với nhé. Cảm ơn các bác nhiều ạ.

mình bị dị ứng với các thể loại cứ làm xong là bên kia thay đổi yêu cầu . nên trong vài ngày tới mình không làm đâu . bạn cứ yên tâm mà chờ thành viên khác

hdg2318 · 19/9/15

doveandrose đã viết:
mình bị dị ứng với các thể loại cứ làm xong là bên kia thay đổi yêu cầu . nên trong vài ngày tới mình không làm đâu . bạn cứ yên tâm mà chờ thành viên khác

Rất xin lỗi vì đã phiền bạn. Thực ra cái này không phải là thay đổi yêu cầu, có lẽ là do lúc đầu mình diễn đạt chưa cặn kẽ và rõ ràng. Mong bạn bỏ quá cho.

Dù sao cũng rất cám ơn sự nhiệt tình của bạn.Nếu không phiền bạn xem giúp mình tại sao lại có số 96 như trong hình với nhé.

Trân trọng!

hdg2318 · 19/9/15

Còn vấn đề tự chạy macro, mình đã xử lý được rồi , có thể dùng code gọi nó ra lúc mở hoặc đóng file

chucuoi92 · 20/9/15

hdg2318 đã viết:
Thanks bác, chuẩn rồi bác ơi. Nhưng e có thắc mắc chút là sao nó lại có cái dòng ô mang giá trị 118 ở bên cột Cod như hình thế ah? ....

Cái này là do xác định mảng arr sai.
mấy số đó chính là số ở dòng Summary by Day

nếu bảng tính không thay đổi về KT thì bạn có thể thay :

PHP:

arr = .Range("C10" & Mid(rgName, InStr(rgName, ":"))).Value

thành :

PHP:

arr = .Range("C10:LA65").value

hdg2318 · 20/9/15

Chu.cuoi92 đã viết:
Cái này là do xác định mảng arr sai.
mấy số đó chính là số ở dòng Summary by Day

nếu bảng tính không thay đổi về KT thì bạn có thể thay :

PHP:

arr = .Range("C10" & Mid(rgName, InStr(rgName, ":"))).Value

thành :

PHP:

arr = .Range("C10:LA65").value

Chuẩn rồi bạn ơi. Thanks bạn nhé.

Bạn có thể giúp mình chỉnh lại code chút xíu được ko? Bỏ dữ liệu bên cột số đi để mình đưa công thức tính tổng từng code bên cạnh vào. nếu bạn sửa được code để nó tự tính tổng luôn thì đẹp quá.

hdg2318 · 20/9/15

doveandrose đã viết:

tính đi rồi mà nghe thầy NDU quảng cáo dữ quá , quay lại đu dây tí . hi hi

Mã:

Public Sub hello()
Dim rgName As String, arr As Variant, Dic As Object, tempKey As Variant
Dim r As Long, c As Long, preDay As Byte, dArr As Variant, arRow(1 To 4) As Long
Set Dic = CreateObject("Scripting.Dictionary")
With [COLOR=#ff0000]Sheet18[/COLOR]
    rgName = .Range("B10").CurrentRegion.Address
    arr = .Range("C10" & Mid(rgName, InStr(rgName, ":"))).Value
    ReDim dArr(1 To 40, 1 To UBound(arr, 2) - 1)
    For c = 2 To UBound(arr, 2) Step 1
        arr(1, c) = IIf(Len(arr(1, c)) > 0, Weekday(arr(1, c), vbMonday), preDay)
        preDay = arr(1, c)
        arRow(1) = 0: arRow(2) = 10: arRow(3) = 20: arRow(4) = 30
        Dic.RemoveAll
        For r = 3 To UBound(arr) Step 1
            If Len(arr(r, c)) > 0 Then
                tempKey = arr(r, 1) & ";" & arr(r, c)
                If Not Dic.exists(tempKey) Then
                    Dic(tempKey) = 1
                    If arr(r, 1) = "Exp" Then
                        If arr(1, c) < 6 Then
                            arRow(1) = WorksheetFunction.Min(arRow(1) + 1, 10)
                            dArr(arRow(1), c - 1) = arr(r, c)
                        End If
                    ElseIf arr(r, 1) = "Imp" Then
                        If arr(1, c) < 6 Then
                            arRow(2) = WorksheetFunction.Min(arRow(2) + 1, 20)
                            dArr(arRow(2), c - 1) = arr(r, c)
                        ElseIf arr(1, c) = 6 Then
                            arRow(3) = WorksheetFunction.Min(arRow(3) + 1, 30)
                            dArr(arRow(3), c - 1) = arr(r, c)
                        Else
                            arRow(4) = WorksheetFunction.Min(arRow(4) + 1, 40)
                            dArr(arRow(4), c - 1) = arr(r, c)
                        End If
                    End If
                End If
            End If
        Next
    Next
    .Range("D" & .Range("D" & Mid(rgName, InStrRev(rgName, "$") + 1)).End(xlDown).Row + 1) _
                .Resize(40, UBound(dArr, 2)).Value = dArr
End With
End Sub

Có bác nào thử code này với file có nhiều sheet chưa ạ? mình làm trên 1 sheet thì ok. Nhưng trên nhiều sheet thì không chạy được.
Có lẽ là do dòng này (mình đoán vậy) mà ko biết sửa thế nào.

With Sheet18

Mong các bạn chỉ giúp.

chucuoi92 · 20/9/15

hdg2318 đã viết:
Có bác nào thử code này với file có nhiều sheet chưa ạ? mình làm trên 1 sheet thì ok. Nhưng trên nhiều sheet thì không chạy được.
Có lẽ là do dòng này (mình đoán vậy) mà ko biết sửa thế nào.

With Sheet18

Nhấp chuột vào đây để mở rộng...

Mong các bạn chỉ giúp.

Có thể sửa thành : With ActiveSheet

còn cái này là tổng thế nào ?

Bạn có thể giúp mình chỉnh lại code chút xíu được ko? Bỏ dữ liệu bên cột số đi để mình đưa công thức tính tổng từng code bên cạnh vào. nếu bạn sửa được code để nó tự tính tổng luôn thì đẹp quá.

hdg2318 · 20/9/15

Chu.cuoi92 đã viết:
Có thể sửa thành : With ActiveSheet

còn cái này là tổng thế nào ?

Thanks bạn.

Mình up file dữ liệu mẫu, đã qua tính toán theo cách thủ công ( chưa áp code vào). Mình đã chú thích thêm trong đó rồi nhé.

chucuoi92 · 20/9/15

hdg2318 đã viết:
Thanks bạn.

Mình up file dữ liệu mẫu, đã qua tính toán theo cách thủ công ( chưa áp code vào). Mình đã chú thích thêm trong đó rồi nhé.

Ý bạn là các mã cùng cột mà trùng nhau thì sum lại với nhau.
vậy thì sửa code lại thành thế này xem sao:

HTML:

Public Sub hello()
Dim arr As Variant, Dic As Object, tempKey As Variant
Dim r As Long, c As Long, preDay As Byte, dArr As Variant, arRow(1 To 4) As Long
Set Dic = CreateObject("Scripting.Dictionary")
With ActiveSheet
    arr = .Range("C10:LA65").Value
    ReDim dArr(1 To 40, 1 To UBound(arr, 2) - 1)
    For c = 2 To UBound(arr, 2) Step 2
        arr(1, c) = IIf(Len(arr(1, c)) > 0, Weekday(arr(1, c), vbMonday), preDay)
        preDay = arr(1, c)
        arRow(1) = 0: arRow(2) = 10: arRow(3) = 20: arRow(4) = 30
        Dic.RemoveAll
        For r = 3 To UBound(arr) Step 1
            If Len(arr(r, c)) > 0 Then
                tempKey = arr(r, 1) & ";" & arr(r, c)
                If Not Dic.exists(tempKey) Then
                          If arr(r, 1) = "Exp" Then
                                If arr(1, c) < 6 Then
                                    arRow(1) = WorksheetFunction.Min(arRow(1) + 1, 10)
                                    Dic.Add tempKey, arRow(1)
                                    dArr(arRow(1), c - 1) = arr(r, c)
                                    dArr(arRow(1), c) = arr(r, c + 1)
                                End If
                            ElseIf arr(r, 1) = "Imp" Then
                                If arr(1, c) < 6 Then
                                    arRow(2) = WorksheetFunction.Min(arRow(2) + 1, 20)
                                    Dic.Add tempKey, arRow(2)
                                    dArr(arRow(2), c - 1) = arr(r, c)
                                    dArr(arRow(2), c) = arr(r, c + 1)
                                ElseIf arr(1, c) = 6 Then
                                    arRow(3) = WorksheetFunction.Min(arRow(3) + 1, 30)
                                    Dic.Add tempKey, arRow(3)
                                    dArr(arRow(3), c - 1) = arr(r, c)
                                    dArr(arRow(3), c) = arr(r, c + 1)
                                Else
                                    arRow(4) = WorksheetFunction.Min(arRow(4) + 1, 40)
                                    Dic.Add tempKey, arRow(4)
                                    dArr(arRow(4), c - 1) = arr(r, c)
                                    dArr(arRow(4), c) = arr(r, c + 1)
                                End If
                            End If
                     Else
                     dArr(Dic.Item(tempKey), c) = dArr(Dic.Item(tempKey), c) + arr(r, c + 1)
                End If
            End If
        Next
    Next
    .Range("D70:LA109") = dArr
End With
End Sub

Lọc danh sách duy nhất cho từng cột riêng rẽ (1 người xem)

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

Thành viên mới

Thành viên mới

File đính kèm

Be all you can be !

Nghị Hách

hello

Thành viên mới

Be all you can be !

Thành viên mới

Be all you can be !

Thành viên mới

Thành viên tiêu biểu

Thành viên mới

hello

Thành viên tiêu biểu

hello

Thành viên tiêu biểu

Nghị Hách

Huyền thoại GPE

Thành viên mới

Huyền thoại GPE

Thành viên tiêu biểu

File đính kèm

Be all you can be !

Huyền thoại GPE

Thành viên mới

File đính kèm

Thành viên tiêu biểu

I don't program, I beat code into submission!!!

Huyền thoại GPE

Thành viên mới

hello

Huyền thoại GPE

Thành viên mới

hello

Thành viên mới

Thành viên mới

Thành viên lười biếng

Thành viên mới

Thành viên mới

Thành viên lười biếng

Thành viên mới

File đính kèm

Thành viên lười biếng

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