Hỏi về trích lọc dữ liệu duy nhất từ một mảng (1 người xem)

khamha · 30/4/13

Chào cả nhà, Như tiêu đề...mình muốn lọc dữ liệu từ một mảng “A5:J” (Tương đương với 10 vùng nằm sát nhau)
* Điều kiện:
1, Lọc lấy dữ liệu duy nhất từ trong mảng.
2, Lọc bằng VBA
3, Dữ liệu sau khi lọc hiển thị bắt đầu tại cột “K5”
Cảm ơn.

Ba Tê · 30/4/13

khamha đã viết:
Chào cả nhà, Như tiêu đề...mình muốn lọc dữ liệu từ một mảng “A5:J” (Tương đương với 10 vùng nằm sát nhau)
* Điều kiện:
1, Lọc lấy dữ liệu duy nhất từ trong mảng.
2, Lọc bằng VBA
3, Dữ liệu sau khi lọc hiển thị bắt đầu tại cột “K5”
Cảm ơn.

Không có file và yêu cầu rõ ràng, chẳng hiểu gì cả.

Quang_Hải · 30/4/13

khamha đã viết:
Chào cả nhà, Như tiêu đề...mình muốn lọc dữ liệu từ một mảng “A5:J” (Tương đương với 10 vùng nằm sát nhau)
* Điều kiện:
1, Lọc lấy dữ liệu duy nhất từ trong mảng.
2, Lọc bằng VBA
3, Dữ liệu sau khi lọc hiển thị bắt đầu tại cột “K5”
Cảm ơn.

PHP:

Sub loc_kieu_thay_boi_mu()
[K5].Resize(1000, 10).ClearContents
[A5].Resize(10000, 10).AdvancedFilter 2, , [K5], 2
End Sub

Ba Tê · 30/4/13

quanghai1969 đã viết:
PHP:

Sub loc_kieu_thay_boi_mu() [K5].Resize(1000, 10).ClearContents [A5].Resize(10000, 10).AdvancedFilter 2, , [K5], 2 End Sub

"Siêu thất nghiệp" quá "siêng".
Bái phục! bái phục!

PhanTuHuong · 30/4/13

"1, Lọc lấy dữ liệu duy nhất từ trong mảng." ---> Cái này em chưa hiểu, tiêu chí???

khamha · 1/5/13

PhanTuHuong đã viết:
"1, Lọc lấy dữ liệu duy nhất từ trong mảng." ---> Cái này em chưa hiểu, tiêu chí???

Mọi người thông cảm nhé...Chung quy chỉ do cái thằng nhà mạng UNITEL (ko biết là do nó hay do máy mình nữa) mà tối qua up File lên ko được ,mà File có nhiều nhặn gì đâu...sau khi nén còn có 8KB mà nó cứ tụt lên tụt xuống ko thể up nổi...̣đúng là ko biết bó tay chấm cái gì nữa.
Các bạn xem File đính kèm và giúp mình nhé.

ndu96081631 · 1/5/13

khamha đã viết:
Mọi người thông cảm nhé...Chung quy chỉ do cái thằng nhà mạng UNITEL (ko biết là do nó hay do máy mình nữa) mà tối qua up File lên ko được ,mà File có nhiều nhặn gì đâu...sau khi nén còn có 8KB mà nó cứ tụt lên tụt xuống ko thể up nổi...̣đúng là ko biết bó tay chấm cái gì nữa.
Các bạn xem File đính kèm và giúp mình nhé.

Dùng cái này:

Mã:

Function UniqueList(ParamArray sArray())
  Dim Item, tmpArr, SubArr, tmp
  'On Error Resume Next
  With CreateObject("Scripting.Dictionary")
    For Each SubArr In sArray
      tmpArr = SubArr
      If Not IsArray(tmpArr) Then tmpArr = Array(tmpArr)
      For Each Item In tmpArr
        tmp = CStr(Item)
        If Len(tmp) Then
          If Not .Exists(tmp) Then .Add tmp, ""
        End If
      Next
    Next
    If .Count Then UniqueList = .Keys
  End With
End Function
Sub Main()
  Dim Arr
  With Sheet1
    .Range("K5:K10000").ClearContents
    Arr = UniqueList(.Range("A5:J10000"))
    If IsArray(Arr) Then .Range("K5").Resize(UBound(Arr) + 1).Value = WorksheetFunction.Transpose(Arr)
  End With
End Sub

Chạy Sub Main sẽ có kết quả

viehoai · 1/5/13

khamha đã viết:
Mọi người thông cảm nhé...Chung quy chỉ do cái thằng nhà mạng UNITEL (ko biết là do nó hay do máy mình nữa) mà tối qua up File lên ko được ,mà File có nhiều nhặn gì đâu...sau khi nén còn có 8KB mà nó cứ tụt lên tụt xuống ko thể up nổi...̣đúng là ko biết bó tay chấm cái gì nữa.
Các bạn xem File đính kèm và giúp mình nhé.

Anh test thử code này xem sao nhé
[GPECODE=vb]
Sub Loc()
Dim Arr(), Tmp(), ArrKq(1 To 10000, 1 To 1)
Dim i&, j&, k&
Arr = Sheet1.Range("A4").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(Arr)
For j = 1 To UBound(Arr, 2)-1
If Arr(i, j) <> "" And Not .Exists(Arr(i, j)) Then
k = k + 1
.Add Arr(i, j), k
ArrKq(k, 1) = Arr(i, j)
End If
Next j
Next
End With
Sheet1.Range("K5").Resize(k).Value = ArrKq
End Sub[/GPECODE]

khamha · 1/5/13

Cách giải quyết của ndu và viehoai đều OK ,Tuy:
1, Của bạn ndu: Code dài ,Lọc loại bỏ các dòng trống.
2, Của bạn viehoai: Code ngắn ,khi lọc lại ko loại bỏ dòng trống "chỉ lọc dữ liệu có liên tục"

ndu96081631 · 1/5/13

khamha đã viết:
Cách giải quyết của ndu và viehoai đều OK ,Tuy:
1, Của bạn ndu: Code dài ,Lọc loại bỏ các dòng trống.
2, Của bạn viehoai: Code ngắn ,khi lọc lại ko loại bỏ dòng trống "chỉ lọc dữ liệu có liên tục"

Code tuy dài nhưng cái hàm UniqueList ấy chỉ viết 1 lần rồi xài mãi mãi. Mai này nếu có áp dụng qua các bài toán khác, cùng lắm bạn chỉ sửa Sub Main là đủ
Ngoài ra cũng xin nói thêm: Hàm UniqueList này không chỉ hoạt động trên Range mà còn làm việc được với mảng (lọc duy nhất trong ListBox, ComboBox chẳng hạn)

Quang_Hải · 1/5/13

khamha đã viết:
Cách giải quyết của ndu và viehoai đều OK ,Tuy:
1, Của bạn ndu: Code dài ,Lọc loại bỏ các dòng trống.
2, Của bạn viehoai: Code ngắn ,khi lọc lại ko loại bỏ dòng trống "chỉ lọc dữ liệu có liên tục"

Vầy cũng ngắn nè.

PHP:

Sub loc()
Dim data(), item
data = [A5].Resize(65000, 10).Value
With CreateObject("scripting.dictionary")
   For Each item In data
      If item <> "" Then
         If Not .exists(item) Then .Add item, ""
      End If
   Next
   [K5].Resize(.Count) = Application.Transpose(.keys)
End With
End Sub

PS: Theo kinh nghiệm thì chịu khó dùng 2 lần If, tránh dùng And thì tốc độ cải thiện đáng kể

hoanglocphat · 1/5/13

ndu96081631 đã viết:

Dùng cái này:

Mã:

Function UniqueList(ParamArray sArray())
  Dim Item, tmpArr, SubArr, tmp
  'On Error Resume Next
  With CreateObject("Scripting.Dictionary")
    For Each SubArr In sArray
      tmpArr = SubArr
      If Not IsArray(tmpArr) Then tmpArr = Array(tmpArr)
      For Each Item In tmpArr
        tmp = CStr(Item)
        If Len(tmp) Then
          If Not .Exists(tmp) Then .Add tmp, ""
        End If
      Next
    Next
    If .Count Then UniqueList = .Keys
  End With
End Function
Sub Main()
  Dim Arr
  With Sheet1
    .Range("K5:K10000").ClearContents
    Arr = UniqueList(.Range("A5:J10000"))
    If IsArray(Arr) Then .Range("K5").Resize(UBound(Arr) + 1).Value = WorksheetFunction.Transpose(Arr)
  End With
End Sub

Chạy Sub Main sẽ có kết quả

Chào các bạn, mình có 1 bài tương tự nên xin chen ngang 1 chút, nhờ tất cả các bạn giúp đỡ

1/ Tại trang "ThongKe" cell C5, sau khi mình chọn "Thang01" thì code sẽ lọc duy nhất của cột D của Sheet" Thang01", và code sẽ cho kết qủa bắt đầu từ cell E7 của sheet "ThongKe". Tương tự nếu chọn cell C5 cua sheet "ThongKe" là "Thang02" thì lọc của Sheet "Thang02"....
2/ Mình muốn chạy code bằng Sub Main như trên, Không chạy bằng sự kiện "Private Sub Worksheet_Change"
3/ Nếu có thể thì sắp xếp theo thứ tự từ nhỏ đến lớn ở cột E của sheet "ThongKe"
--------------
Chủ đề lọc duy nhất có nhiều trên diễn đàn nhưng mình cũng kg biếp áp dụng sao cho trường hợp của mình
Xin cảm ơn tất cả

Quang_Hải · 1/5/13

hoanglocphat đã viết:
Chào các bạn, mình có 1 bài tương tự nên xin chen ngang 1 chút, nhờ tất cả các bạn giúp đỡ

1/ Tại trang "ThongKe" cell C5, sau khi mình chọn "Thang01" thì code sẽ lọc duy nhất của cột D của Sheet" Thang01", và code sẽ cho kết qủa bắt đầu từ cell E7 của sheet "ThongKe". Tương tự nếu chọn cell C5 cua sheet "ThongKe" là "Thang02" thì lọc của Sheet "Thang02"....
2/ Mình muốn chạy code bằng Sub Main như trên, Không chạy bằng sự kiện "Private Sub Worksheet_Change"
3/ Nếu có thể thì sắp xếp theo thứ tự từ nhỏ đến lớn ở cột E của sheet "ThongKe"
--------------
Chủ đề lọc duy nhất có nhiều trên diễn đàn nhưng mình cũng kg biếp áp dụng sao cho trường hợp của mình
Xin cảm ơn tất cả

Thử cái này coi

PHP:

Sub loc()
With Sheets([C5].Value)
   .[D7:D65536].AdvancedFilter 2, , [E6], 2
End With
End Sub

ndu96081631 · 1/5/13

hoanglocphat đã viết:
Chào các bạn, mình có 1 bài tương tự nên xin chen ngang 1 chút, nhờ tất cả các bạn giúp đỡ

1/ Tại trang "ThongKe" cell C5, sau khi mình chọn "Thang01" thì code sẽ lọc duy nhất của cột D của Sheet" Thang01", và code sẽ cho kết qủa bắt đầu từ cell E7 của sheet "ThongKe". Tương tự nếu chọn cell C5 cua sheet "ThongKe" là "Thang02" thì lọc của Sheet "Thang02"....
2/ Mình muốn chạy code bằng Sub Main như trên, Không chạy bằng sự kiện "Private Sub Worksheet_Change"
3/ Nếu có thể thì sắp xếp theo thứ tự từ nhỏ đến lớn ở cột E của sheet "ThongKe"
--------------
Chủ đề lọc duy nhất có nhiều trên diễn đàn nhưng mình cũng kg biếp áp dụng sao cho trường hợp của mình
Xin cảm ơn tất cả

Sửa Sub Main thành vầy:

Mã:

Sub Main()
  Dim Arr
  Dim wks As Worksheet, rng As Range
  On Error Resume Next
  With Worksheets("ThongKe")
    Set wks = Worksheets(.Range("C5").Value)
    Set rng = wks.Range("D8:D10000")
    .Range("E7:E10000").ClearContents
    Arr = UniqueList(rng)
    If IsArray(Arr) Then
      Arr = WorksheetFunction.Transpose(Arr)
      With .Range("E7").Resize(UBound(Arr))
        .Value = Arr
        .Sort .Cells(1, 1), 1, Header:=xlNo
      End With
    End If
  End With
End Sub

khamha · 9/5/13

quanghai1969 đã viết:
Vầy cũng ngắn nè.

PHP:

Sub loc() Dim data(), item data = [A5].Resize(65000, 10).Value With CreateObject("scripting.dictionary") For Each item In data If item <> "" Then If Not .exists(item) Then .Add item, "" End If Next [K5].Resize(.Count) = Application.Transpose(.keys) End With End Sub

PS: Theo kinh nghiệm thì chịu khó dùng 2 lần If, tránh dùng And thì tốc độ cải thiện đáng kể

Mình sử dụng đoạn Code trên...và nhờ các bạn giúp thêm vấn đề tính tổng cho từng nội dung (Các bạn xem File đính kèm)

Ba Tê · 9/5/13

khamha đã viết:
Mình sử dụng đoạn Code trên...và nhờ các bạn giúp thêm vấn đề tính tổng cho từng nội dung (Các bạn xem File đính kèm)

Thử với Sub này xem sao.

PHP:

Public Sub GPE()
Dim Arr1(), Arr2(), Darr(), I As Long, J As Long, K As Long, Tem As String, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Arr1 = Range([A5], [A65000].End(xlUp)).Resize(, 12).Value
Arr2 = Range([A5], [A65000].End(xlUp)).Offset(, 12).Resize(, 12).Value
ReDim Darr(1 To UBound(Arr1, 1) * 12, 1 To 2)
For J = 1 To 12
    For I = 1 To UBound(Arr1, 1)
        If Arr1(I, J) <> "" Then
            Tem = Arr1(I, J)
            If Not Dic.Exists(Tem) Then
                K = K + 1
                Dic.Add (Tem), K
                Darr(K, 1) = Tem: Darr(K, 2) = Arr2(I, J)
            Else
                Darr(Dic.item(Tem), 2) = Darr(Dic.item(Tem), 2) + Arr2(I, J)
            End If
        End If
    Next I
Next J
[Y5:Z65000].ClearContents
If K Then [Y5].Resize(K, 2).Value = Darr
Set Dic = Nothing
End Sub

khamha · 9/5/13

Ba Tê đã viết:

Thử với Sub này xem sao.

PHP:

Public Sub GPE()
Dim Arr1(), Arr2(), Darr(), I As Long, J As Long, K As Long, Tem As String, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Arr1 = Range([A5], [A65000].End(xlUp)).Resize(, 12).Value
Arr2 = Range([A5], [A65000].End(xlUp)).Offset(, 12).Resize(, 12).Value
ReDim Darr(1 To UBound(Arr1, 1) * 12, 1 To 2)
For J = 1 To 12
    For I = 1 To UBound(Arr1, 1)
        If Arr1(I, J) <> "" Then
            Tem = Arr1(I, J)
            If Not Dic.Exists(Tem) Then
                K = K + 1
                Dic.Add (Tem), K
                Darr(K, 1) = Tem: Darr(K, 2) = Arr2(I, J)
            Else
                Darr(Dic.item(Tem), 2) = Darr(Dic.item(Tem), 2) + Arr2(I, J)
            End If
        End If
    Next I
Next J
[Y5:Z65000].ClearContents
If K Then [Y5].Resize(K, 2).Value = Darr
Set Dic = Nothing
End Sub

Cảm ơn bạn BaTê ,Code chuẩn...Nhưng mình lại quên là khi hoạt động thì ngoài loại bỏ dòng trống ra còn phải loại bỏ cá dấu chấm "." và phẩy "," nữa ,Bạn thông cảm...Và giúp mình nhé.

Ba Tê · 9/5/13

khamha đã viết:
Cảm ơn bạn BaTê ,Code chuẩn...Nhưng mình lại quên là khi hoạt động thì ngoài loại bỏ dòng trống ra còn phải loại bỏ cá dấu chấm "." và phẩy "," nữa ,Bạn thông cảm...Và giúp mình nhé.

Dấu chấm, phẩy ở đâu "Chời", Các mã a1, a2, fdfd ... gì đó của bạn ít nhất bao nhiêu ký tự? Bạn đưa dữ liệu "hơi thật" một chút xem.
Nếu các mã luôn từ 2 ký tự trở lên thì thằng nào chỉ có 1 ký tự không tính.

PHP:

Public Sub GPE()
Dim Arr1(), Arr2(), Darr(), I As Long, J As Long, K As Long, Tem As String, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Arr1 = Range([A5], [A65000].End(xlUp)).Resize(, 12).Value
Arr2 = Range([A5], [A65000].End(xlUp)).Offset(, 12).Resize(, 12).Value
ReDim Darr(1 To UBound(Arr1, 1) * 12, 1 To 2)
For J = 1 To 12
    For I = 1 To UBound(Arr1, 1)
            Tem = Arr1(I, J)
        If Len(Arr1(I, J)) >= 2 Then
            If Not Dic.Exists(Tem) Then
                K = K + 1
                Dic.Add (Tem), K
                Darr(K, 1) = Tem: Darr(K, 2) = Arr2(I, J)
            Else
                Darr(Dic.item(Tem), 2) = Darr(Dic.item(Tem), 2) + Arr2(I, J)
            End If
        End If
    Next I
Next J
[Y5:Z65000].ClearContents
If K Then [Y5].Resize(K, 2).Value = Darr
Set Dic = Nothing
End Sub

ndu96081631 · 9/5/13

Ba Tê đã viết:

Thử với Sub này xem sao.

PHP:

Public Sub GPE()
Dim Arr1(), Arr2(), Darr(), I As Long, J As Long, K As Long, Tem As String, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Arr1 = Range([A5], [A65000].End(xlUp)).Resize(, 12).Value
Arr2 = Range([A5], [A65000].End(xlUp)).Offset(, 12).Resize(, 12).Value
ReDim Darr(1 To UBound(Arr1, 1) * 12, 1 To 2)
For J = 1 To 12
    For I = 1 To UBound(Arr1, 1)
        If Arr1(I, J) <> "" Then
            Tem = Arr1(I, J)
            If Not Dic.Exists(Tem) Then
                K = K + 1
                Dic.Add (Tem), K
                Darr(K, 1) = Tem: Darr(K, 2) = Arr2(I, J)
            Else
                Darr(Dic.item(Tem), 2) = Darr(Dic.item(Tem), 2) + Arr2(I, J)
            End If
        End If
    Next I
Next J
[Y5:Z65000].ClearContents
If K Then [Y5].Resize(K, 2).Value = Darr
Set Dic = Nothing
End Sub

Với code này, nếu xóa: A15:A17 và M15:M17 thì kết quả sẽ sai
Với dạng dữ liệu không có quy luật thế này, ta không nên End(xlUp) làm gì cho mất công ---> Cứ "phang" thằng từ A5 đến L20000 cho nó chắc

Ba Tê · 9/5/13

ndu96081631 đã viết:
Với code này, nếu xóa: A15:A17 và M15:M17 thì kết quả sẽ sai
Với dạng dữ liệu không có quy luật thế này, ta không nên End(xlUp) là gì cho mất công ---> Cứ "phang" thằng từ A5 đến L20000 cho nó chắc

Vậy phải xác định dòng cuối cùng có dữ liệu trong cột A:L
Hay cho nó "mút chỉ" luôn đến 65536?

sealand · 9/5/13

Theo mình KhanHa nên chuyển Code như sau dễ hiệu chỉnh và điều khiển cộng dữ liệu vì ta dùng luôn Item của Dic tính giá trị Tổng luôn

Mã:

Private Sub CommandButton1_Click()
 Dim Data1, Data2, i, j
  Data1 = [A5].Resize(65000, 12).Value
   Data2 = [M5].Resize(65000, 12).Value
    With CreateObject("scripting.dictionary")
     For i = 1 To UBound(Data1, 1)
      For j = 1 To UBound(Data1, 2)
       If Data1(i, j) <> "" Then
        If Not .Exists(Data1(i, j)) Then
         .Add Data1(i, j), Data2(i, j)
          Else
         .item(Data1(i, j)) = .item(Data1(i, j)) + Data2(i, j)
       End If
      End If
    Next
   Next
  Range("Y5:Y" & [Y5].End(xlDown).Row).ClearContents
 [Y5].Resize(.Count) = Application.Transpose(.keys)
[Z5].Resize(.Count) = Application.Transpose(.Items)
End With
End Sub

khamha · 9/5/13

Các bạn xem thêm các điều kiện:
1, Trong các ô nội dung: có nội dung là Text “có ít trường hợp có kèm theo số” và nội dung trong các ô là từ 2 trở lên ,nếu ko có nội dung thì sẽ nhập dấu chấm “.”
2, Trong các ô số tiền: có nội dung là số ,nếu ô tương ứng trong ô nội dung là dấu chấm “.” Thì ô tại số tiền sẽ nhập số 0 “không” và hiện thị dưới dạng "-"
3, Tại Cột N1 dữ liệu là liên tục.

ndu96081631 · 9/5/13

khamha đã viết:
Các bạn xem thêm các điều kiện:
1, Trong các ô nội dung: có nội dung là Text “có ít trường hợp có kèm theo số” và nội dung trong các ô là từ 2 trở lên ,nếu ko có nội dung thì sẽ nhập dấu chấm “.”
2, Trong các ô số tiền: có nội dung là số ,nếu ô tương ứng trong ô nội dung là dấu chấm “.” Thì ô tại số tiền sẽ nhập số 0 “không” và hiện thị dưới dạng "-"
3, Tại Cột N1 dữ liệu là liên tục.

Tặng bạn hàm SummaryData chuyên làm việc này:

Mã:

Function SummaryData(ByVal DataRange As Range, ByVal SumRange As Range)
  Dim lR As Long, lC As Long, n As Long,
  Dim aData, aSum, tmp1, tmp2
  On Error Resume Next
  If DataRange.Count > 1 Then
    aData = DataRange.Value: aSum = SumRange.Value
    ReDim arr(1 To 2, 1 To 1)
    With CreateObject("Scripting.Dictionary")
      For lR = 1 To UBound(aData, 1)
        For lC = 1 To UBound(aData, 2)
          tmp1 = CStr(aData(lR, lC))
          tmp2 = CDbl(aSum(lR, lC))
          If Len(tmp1) Then
            If Not .Exists(tmp1) Then
              n = n + 1
              .Add tmp1, n
              ReDim Preserve arr(1 To 2, 1 To n)
              arr(1, n) = tmp1
              arr(2, n) = tmp2
            Else
              arr(2, .item(tmp1)) = arr(2, .item(tmp1)) + tmp2
            End If
          End If
        Next
      Next
      If n Then
        ReDim aRes(1 To n, 1 To 2)
        For lR = 1 To UBound(arr, 2)
          aRes(lR, 1) = arr(1, lR)
          aRes(lR, 2) = arr(2, lR)
        Next
        SummaryData = aRes
      End If
    End With
  End If
End Function

Viết code áp dụng để tổng hợp:

Mã:

Sub Main()
  Dim aRes
  Application.ScreenUpdating = False
  With Sheet1
    .Range("Y5:Z20000").ClearContents
    aRes = [B]SummaryData([COLOR=#ff0000].Range("A5:L20000")[/COLOR], .[COLOR=#0000cd]Range("M5:X20000")[/COLOR])[/B]
    If IsArray(aRes) Then
      .Range("Y5:Z5").Resize(UBound(aRes, 1), 2).Value = aRes
    End If
  End With
  Application.ScreenUpdating = True
End Sub

Chỉ cần nhớ cú pháp của hàm: SummaryData(Vùng dữ liệu, Vùng tính tổng) là được rồi
Code trong hàm bạn không cần quan tâm, mai này áp dụng cho dữ liệu khác, chỉ cần sửa Sub Main, thay đổi tham chiếu cho phù hợp là xong!

sealand · 9/5/13

khamha đã viết:
Các bạn xem thêm các điều kiện:
1, Trong các ô nội dung: có nội dung là Text “có ít trường hợp có kèm theo số” và nội dung trong các ô là từ 2 trở lên ,nếu ko có nội dung thì sẽ nhập dấu chấm “.”
2, Trong các ô số tiền: có nội dung là số ,nếu ô tương ứng trong ô nội dung là dấu chấm “.” Thì ô tại số tiền sẽ nhập số 0 “không” và hiện thị dưới dạng "-"
3, Tại Cột N1 dữ liệu là liên tục.

Mình hiệu chỉnh Code như sau:

PHP:

Private Sub CommandButton1_Click()
 Dim Data1, Data2, i, j
  Data1 = [A5].Resize(65000, 12).Value
   Data2 = [M5].Resize(65000, 12).Value
    With CreateObject("scripting.dictionary")
     For i = 1 To UBound(Data1, 1)
      For j = 1 To UBound(Data1, 2)
       If Data1(i, j) <> "" Or Data1(i, j) <> "." Then
         If Not .Exists(Data1(i, j)) Then
         .Add Data1(i, j), Data2(i, j)
          Else
         .item(Data1(i, j)) = .item(Data1(i, j)) + Data2(i, j)
       End If
       Else
       Data1(i, j) = ".": Data2(i, j) = 0
      End If
    Next
   Next
  Range("Y5:Y" & [Y5].End(xlDown).Row).ClearContents
 [Y5].Resize(.Count) = Application.Transpose(.keys)
[Z5].Resize(.Count) = Application.Transpose(.Items)
End With
[A5].Resize(65000, 12).Value = Data1
[M5].Resize(65000, 12).Value = Data2
[M5].Resize(65000, 12).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
End Sub

khamha · 10/5/13

Cảm ơn các bạn đã giúp ,Các cách trên phải nói là rất chuẩn ,Tuy nó vẫn chưa loại được các nội dung có dấu chấm “.” .
Mình có một bài nữa nhờ các bạn giúp ,nó cũng tương tự như bài trên ,chỉ thêm một điều kiện nữa ,Nên mình hỏi luôn ở đây ,Để dễ hiểu ,Các bạn xem File giúp mình tiếp nhé.
* Điều kiện:
1, Lọc thêm loại "L1 ,L2...L5"
2, Sắp xếp nội dung sau khi lọc theo danh sách trước , sau giống như dữ liệu nguồn ở Cột "AL"

* Nhờ MOD xóa hộ File đính kèm: Loc2DieuKien-TinhTong.7z ---> Xong

concogia · 10/5/13

khamha đã viết:
Cảm ơn các bạn đã giúp ,Các cách trên phải nói là rất chuẩn ,Tuy nó vẫn chưa loại được các nội dung có dấu chấm “.” .
Mình có một bài nữa nhờ các bạn giúp ,nó cũng tương tự như bài trên ,chỉ thêm một điều kiện nữa ,Nên mình hỏi luôn ở đây ,Để dễ hiểu ,Các bạn xem File giúp mình tiếp nhé.
* Điều kiện:
1, Lọc thêm loại "L1 ,L2...L5"
2, Sắp xếp nội dung sau khi lọc theo danh sách trước , sau giống như dữ liệu nguồn ở Cột "AL"

* Nhờ MOD xóa hộ File đính kèm: Loc2DieuKien-TinhTong.7z

Bạn khamha thân mến, bạn có thể dịch giúp mình sang tiếng Lào mấy câu này được không

Bạn có thể vui lòng phang vào cái bảng của bạn kết quả mà bạn muốn, xem mặt mũi nó ra sao ????
Đoạn từ cột Z ==> AI thỉ hơi hơi hiểu,không biết khi lọc ra nó xếp liên tục hay nhảy cà tưng theo cột AL ?
Còn cột AJ & AK thì............cóc có hiểu

Híc
Thân

khamha · 10/5/13

concogia đã viết:
Bạn khamha thân mến, bạn có thể dịch giúp mình sang tiếng Lào mấy câu này được không

Híc
Thân

Đã phang theo lệnh của SPCG và sửa lại ý là: lọc xong thì chuyển kết quả sang Sheet "BáoCáo1" ,SPCG xem và giúp khamha nhé,Thank
* Sắp xếp nội dung sau khi lọc theo danh sách trước , sau giống như dữ liệu nguồn.

sealand · 10/5/13

khamha đã viết:
Cảm ơn các bạn đã giúp ,Các cách trên phải nói là rất chuẩn ,Tuy nó vẫn chưa loại được các nội dung có dấu chấm “.” .
Mình có một bài nữa nhờ các bạn giúp ,nó cũng tương tự như bài trên ,chỉ thêm một điều kiện nữa ,Nên mình hỏi luôn ở đây ,Để dễ hiểu ,Các bạn xem File giúp mình tiếp nhé.
* Điều kiện:
1, Lọc thêm loại "L1 ,L2...L5"
2, Sắp xếp nội dung sau khi lọc theo danh sách trước , sau giống như dữ liệu nguồn ở Cột "AL"

* Nhờ MOD xóa hộ File đính kèm: Loc2DieuKien-TinhTong.7z ---> Xong

Tự mình xoá file kèm được mà, vào sửa bài---Chọn khung lớn---Chọn tải file từ máy
Trong đó có sẵn file kèm, chọn nó rồi nhấn Remove là được

concogia · 10/5/13

khamha đã viết:
Đã phang theo lệnh của SPCG và sửa lại ý là: lọc xong thì chuyển kết quả sang Sheet "BáoCáo1" ,SPCG xem và giúp khamha nhé,Thank
* Sắp xếp nội dung sau khi lọc theo danh sách trước , sau giống như dữ liệu nguồn.

1)- Dữ liệu sao dấu cột, coi chừng lại sửa nữa
2)- Dữ liệu giả định, có cái bảng "Nội dung" để làm chuẩn sắp xếp thì..........lại xóa đi mất, biết sắp xếp kiểu nào hả Trời ??? - Phục hồi lại cái bảng đó
3)- Dữ liệu lúc thì có cái dấu chấm, lúc thì để trống, mắc cười chưa ???
Híc
Thử chạy code này:

Mã:

Public Sub GPE()
    Dim Vung, NoiDung, Loai, Cot, Hang, Tam, I, J, K, Mg, d, Kq
    Vung = Sheets("F").Range(Sheets("F").[AH6], Sheets("F").[AH50000].End(xlUp)).Resize(, 35)
    Set d = CreateObject("scripting.dictionary")
    Set NoiDung = Sheets("F").Range(Sheets("F").[BR6], Sheets("F").[BR5000].End(xlUp))
    Set Loai = Sheets("BC1").Range("C6:G6")
    ReDim Mg(1 To NoiDung.Rows.Count, 1 To 6)
        For I = 1 To UBound(Vung)
            For J = 11 To 22
                If Vung(I, J) <> "." Then
                    If Vung(I, J) <> " " Then
                        Tam = Vung(I, 1) & Vung(I, J)
                            Cot = Application.WorksheetFunction.Match(Vung(I, 1), Loai, 0)
                            Hang = Application.WorksheetFunction.Match(Vung(I, J), NoiDung, 0)
                            If Not d.exists(Tam) Then
                                d.Add Tam, ""
                                Mg(Hang, 1) = Vung(I, J): Mg(Hang, Cot + 1) = Vung(I, J + 12)
                            Else
                                Mg(Hang, Cot + 1) = Mg(Hang, Cot + 1) + Vung(I, J + 12)
                            End If
                     End If
                  End If
                  
            Next J
        Next I
            ReDim Kq(1 To d.Count, 1 To 6)
            For I = 1 To NoiDung.Rows.Count
                If Mg(I, 1) <> "" Then
                    K = K + 1
                    For J = 1 To 6
                        Kq(K, J) = Mg(I, J)
                    Next J
                End If
            Next I
    Sheets("BC1").[B9].Resize(K, 6) = Kq
    Range([B9], [b1000].End(xlUp)).Offset(, -1) = [row(A:A)]
End Sub

Thân
Xí quên, các công thức trong bảng kết quả mình hổng có đụng tới nó à nha, code chạy từ cột A ==> G, phần màu vàng cũng hông có đụng tới luôn

khamha · 10/5/13

concogia đã viết:

1)- Dữ liệu sao dấu cột, coi chừng lại sửa nữa
2)- Dữ liệu giả định, có cái bảng "Nội dung" để làm chuẩn sắp xếp thì..........lại xóa đi mất, biết sắp xếp kiểu nào hả Trời ??? - Phục hồi lại cái bảng đó
3)- Dữ liệu lúc thì có cái dấu chấm, lúc thì để trống, mắc cười chưa ???
Híc
Thử chạy code này:

Mã:

Public Sub GPE()
    Dim Vung, NoiDung, Loai, Cot, Hang, Tam, I, J, K, Mg, d, Kq
    Vung = Sheets("F").Range(Sheets("F").[AH6], Sheets("F").[AH50000].End(xlUp)).Resize(, 35)
    Set d = CreateObject("scripting.dictionary")
    Set NoiDung = Sheets("F").Range(Sheets("F").[BR6], Sheets("F").[BR5000].End(xlUp))
    Set Loai = Sheets("BC1").Range("C6:G6")
    ReDim Mg(1 To NoiDung.Rows.Count, 1 To 6)
        For I = 1 To UBound(Vung)
            For J = 11 To 22
                If Vung(I, J) <> "." Then
                    If Vung(I, J) <> " " Then
                        Tam = Vung(I, 1) & Vung(I, J)
                            Cot = Application.WorksheetFunction.Match(Vung(I, 1), Loai, 0)
                            Hang = Application.WorksheetFunction.Match(Vung(I, J), NoiDung, 0)
                            If Not d.exists(Tam) Then
                                d.Add Tam, ""
                                Mg(Hang, 1) = Vung(I, J): Mg(Hang, Cot + 1) = Vung(I, J + 12)
                            Else
                                Mg(Hang, Cot + 1) = Mg(Hang, Cot + 1) + Vung(I, J + 12)
                            End If
                     End If
                  End If
                  
            Next J
        Next I
            ReDim Kq(1 To d.Count, 1 To 6)
            For I = 1 To NoiDung.Rows.Count
                If Mg(I, 1) <> "" Then
                    K = K + 1
                    For J = 1 To 6
                        Kq(K, J) = Mg(I, J)
                    Next J
                End If
            Next I
    Sheets("BC1").[B9].Resize(K, 6) = Kq
    Range([B9], [b1000].End(xlUp)).Offset(, -1) = [row(A:A)]
End Sub

Thân
Xí quên, các công thức trong bảng kết quả mình hổng có đụng tới nó à nha, code chạy từ cột A ==> G, phần màu vàng cũng hông có đụng tới luôn

Chà...Chuẩn ko cần chỉnh ,Tiếc là ko ở gần nhau...Chứ ở gần là bắt phải đi nhậu một bữa "Ko say ko về" Cảm ơn SPCG nhiều.

khamha · 10/5/13

Nhờ SPCG giúp bổ sung cho cái bài trên như sau:
- Tự động ẩn dòng trống ,sau khi cập nhật dữ liệu (xem ảnh)

* Trong File trên ,Còn phải lọc thêm 03 kiểu “BáoCáo” nữa , Trong 03 kiểu “BáoCáo” đó phải lọc dữ liệu từ 02 Sheet...là Sheet “F_TDN” (Từ đầu năm) và Sheet “F” (Tháng này) , nhờ SPCG bớt chút thời gian,giúp mình tiếp nhé,Thank

khamha · 11/5/13

Do mạng chậm quá ,khi mở ra chỉ thấy 3 trang,cứ tưởng là bài chưa gửi được ,nên lại gửi tiếp...nhân tiện thử xem chỉ dẫn của bạn Sealand luôn.

sealand đã viết:
Tự mình xoá file kèm được mà, vào sửa bài---Chọn khung lớn---Chọn tải file từ máy
Trong đó có sẵn file kèm, chọn nó rồi nhấn Remove là được

concogia · 12/5/13

khamha đã viết:
Nhờ SPCG giúp bổ sung cho cái bài trên như sau:
- Tự động ẩn dòng trống ,sau khi cập nhật dữ liệu (xem ảnh)

* Trong File trên ,Còn phải lọc thêm 03 kiểu “BáoCáo” nữa , Trong 03 kiểu “BáoCáo” đó phải lọc dữ liệu từ 02 Sheet...là Sheet “F_TDN” (Từ đầu năm) và Sheet “F” (Tháng này) , nhờ SPCG bớt chút thời gian,giúp mình tiếp nhé,Thank

Bài này còn nhiều vấn đề chưa hiểu lắm, làm tạm thôi, xỉn quá rồi
Bạn kiểm tra giúp
Thân

khamha · 13/5/13

concogia đã viết:
Bài này còn nhiều vấn đề chưa hiểu lắm, làm tạm thôi, xỉn quá rồi
Bạn kiểm tra giúp
Thân

Đúng là nội công của SPCG thâm hậu thật ,đang xỉn mà viết Code vẫn chuẩn.
Mấy cái báo cáo đấy ,trước đây mình làm thủ công và theo cách củ chuối của riêng mình ,thì cái File rất nặng (hơn 3M) và chạy rất nhanh như rùa...

Nhờ SPCG giúp mình thêm một vấn đề nữa là: nếu chỉ lọc một danh sách ,loại bỏ dữ liệu trùng và sắp xếp theo thứ tự đã quy định sẵn thì phải sửa đoạn Code lại như thế nào ? ví dụ mình muốn lọc "Bộ Phận" chẳng hạn.Thank

concogia · 14/5/13

khamha đã viết:
Nhờ SPCG giúp mình thêm một vấn đề nữa là: nếu chỉ lọc một danh sách ,loại bỏ dữ liệu trùng và sắp xếp theo thứ tự đã quy định sẵn thì phải sửa đoạn Code lại như thế nào ? ví dụ mình muốn lọc "Bộ Phận" chẳng hạn.Thank

Híc

Khamha vui lòng gởi file, nói rõ yêu cầu lọc, kết quả ra sao? Kết quả xuất ra ở chỗ nào ?...
Híc, gởi bài quá trời mà còn hỏi như "dzị", trách chi thành viên mới
Thân

khamha · 14/5/13

Vì phải áp dụng vào nhiều File khác lên tiện thể hỏi một chỗ luôn ,Mình cũng tự mày mò sửa bớt cái Code của SPCG nhưng chắc do trình độ quá cùn lên cứa hổng có đứt !!!
Ý mình là chỉ muốn lọc dữ liệu trùng và sắp xếp lại theo danh sách có sẵn ,chứ ko cần tính toán nữa.SP xem File giúp mình nhé.

SPCG nói như bài trên đúng quá !!! Chắc phải đề nghị Admin bớt sao mới được...

Ba Tê · 14/5/13

khamha đã viết:
Vì phải áp dụng vào nhiều File khác lên tiện thể hỏi một chỗ luôn ,Mình cũng tự mày mò sửa bớt cái Code của SPCG nhưng chắc do trình độ quá cùn lên cứa hổng có đứt !!!
Ý mình là chỉ muốn lọc dữ liệu trùng và sắp xếp lại theo danh sách có sẵn ,chứ ko cần tính toán nữa.SP xem File giúp mình nhé.

SPCG nói như bài trên đúng quá !!! Chắc phải đề nghị Admin bớt sao mới được...

Với kiểu dữ liệu "ví dụ a1,B1,Q1..." rồi kéo xuống đến 100 chắc không thật, rồi sort theo kiểu số hay kiểu chuỗi?
Tạm Sort theo kiểu chuỗi đi, hổng chịu thì nhờ "Lão Cò" uýnh tiếp.
Híc!

khamha · 14/5/13

Ba Tê đã viết:
Với kiểu dữ liệu "ví dụ a1,B1,Q1..." rồi kéo xuống đến 100 chắc không thật, rồi sort theo kiểu số hay kiểu chuỗi?
Tạm Sort theo kiểu chuỗi đi, hổng chịu thì nhờ "Lão Cò" uýnh tiếp.
Híc!

Cảm ơn bạn BaTê, sort theo chuỗi là OK ,Nhưng nó chưa sắp xếp theo danh sách trước sau có sẵn trong cột:
F!BR = Nội Dung
F!BS = Bộ Phận
F!BT = Quy Cách

concogia · 14/5/13

Ba Tê đã viết:
Với kiểu dữ liệu "ví dụ a1,B1,Q1..." rồi kéo xuống đến 100 chắc không thật, rồi sort theo kiểu số hay kiểu chuỗi?
Tạm Sort theo kiểu chuỗi đi, hổng chịu thì nhờ "Lão Cò" uýnh tiếp.
Híc!

Híc, tưng quá
Không cần sort đâu bạn già Ba Tê ạ, nên không quan tâm sắp xếp theo kiểu số hay chuỗi. Ta sắp xếp theo bảng dữ liệu cho trước, trong bài là 3 bảng "Nội dung" , "Quy cách", "Bộ phận"
Mỗi người có một cách giải khác nhau, mình thì làm theo kiểu thế này, thí dụ với "Quy cách"
Tạo nút bấm ở sheet "Quycach" ( đây chỉ là ví dụ, bạn có thể chạy code tùy ý) chạy code này:

Mã:

Private Sub CommandButton1_Click()
    Dim QuyCach As Range, Vung As Variant, I As Long, K As Long, d As Object, Hang As Long, Tam As Variant, Kq As Variant
    Set d = CreateObject("scripting.dictionary")
    Set QuyCach = Sheets("F").Range(Sheets("F").[BT6], Sheets("F").[BT10000].End(xlUp))
    ReDim Tam(1 To QuyCach.Rows.Count, 1 To 1)
    Vung = Sheets("F").Range(Sheets("F").[AG6], Sheets("F").[AG10000].End(xlUp))
        For I = 1 To UBound(Vung)
            If Not d.exists(Vung(I, 1)) Then
                Hang = Application.WorksheetFunction.Match(Vung(I, 1), QuyCach, 0)
                d.Add Vung(I, 1), ""
                Tam(Hang, 1) = Vung(I, 1)
            End If
        Next I
            ReDim Kq(1 To QuyCach.Rows.Count, 1 To 1)
            For I = 1 To QuyCach.Rows.Count
                If Tam(I, 1) <> "" Then
                    K = K + 1
                    Kq(K, 1) = Tam(I, 1)
                End If
            Next I
    Sheets("quycach").[D10].Resize(K, 1) = Kq
End Sub

Tưng quá, làm một cái thôi, 2 cái còn lại tương tự, riêng mấy cái thằng a1, a2..............phải thêm điều kiện khác dấu chấm (".")
Nếu trúng thì tốt, hổng trúng thì bạn khamha nhờ thầy Ba Tê giúp tiếp nhé, hihi
Híc
Thân

khamha · 15/5/13

concogia đã viết:
Híc, tưng quá
Không cần sort đâu bạn già Ba Tê ạ, nên không quan tâm sắp xếp theo kiểu số hay chuỗi. Ta sắp xếp theo bảng dữ liệu cho trước, trong bài là 3 bảng "Nội dung" , "Quy cách", "Bộ phận"
Mỗi người có một cách giải khác nhau, mình thì làm theo kiểu thế này, thí dụ với "Quy cách"
Tạo nút bấm ở sheet "Quycach" ( đây chỉ là ví dụ, bạn có thể chạy code tùy ý) chạy code này:

Mã:

Private Sub CommandButton1_Click() Dim QuyCach As Range, Vung As Variant, I As Long, K As Long, d As Object, Hang As Long, Tam As Variant, Kq As Variant Set d = CreateObject("scripting.dictionary") Set QuyCach = Sheets("F").Range(Sheets("F").[BT6], Sheets("F").[BT10000].End(xlUp)) ReDim Tam(1 To QuyCach.Rows.Count, 1 To 1) Vung = Sheets("F").Range(Sheets("F").[AG6], Sheets("F").[AG10000].End(xlUp)) For I = 1 To UBound(Vung) If Not d.exists(Vung(I, 1)) Then Hang = Application.WorksheetFunction.Match(Vung(I, 1), QuyCach, 0) d.Add Vung(I, 1), "" Tam(Hang, 1) = Vung(I, 1) End If Next I ReDim Kq(1 To QuyCach.Rows.Count, 1 To 1) For I = 1 To QuyCach.Rows.Count If Tam(I, 1) <> "" Then K = K + 1 Kq(K, 1) = Tam(I, 1) End If Next I Sheets("quycach").[D10].Resize(K, 1) = Kq End Sub

Tưng quá, làm một cái thôi, 2 cái còn lại tương tự, riêng mấy cái thằng a1, a2..............phải thêm điều kiện khác dấu chấm (".")
Nếu trúng thì tốt, hổng trúng thì bạn khamha nhờ thầy Ba Tê giúp tiếp nhé, hihi
Híc
Thân

SPCG xem lại giúp mình ,sao cái Code trên nó hoạt động trong Sheet"NoiDung" ko đúng?Thank

concogia · 15/5/13

khamha đã viết:
SPCG xem lại giúp mình ,sao cái Code trên nó hoạt động trong Sheet"NoiDung" ko đúng?Thank

Híc, trong sheet "NoiDung" bạn phải khai báo vùng dữ liệu ( trong code là biến "Vung") là:

Vung = Sheets("F").Range(Sheets("F").[AR6], Sheets("F").[AR10000].End(xlUp)).Resize(,12)

Vì vùng dữ liệu lớn hơn 1 cột, bạn phải cho chạy 2 biến, nhưng trong bài chỉ cần lọc duy nhất & sắp xếp theo bảng có trước nên chỉ cần dùng For Each chạy hết biến "Vung"
Híc, mình gợi ý thế, bạn khamha thử sửa code xem có được không, nếu "tèo" thì tý nữa mình làm cho, để đi tắm một cái, nóng quá, Sì- Gòn hôm nay nóng "kinh khủng khiếp", bên Lào có nóng hông ??????
Thân

concogia · 15/5/13

Code nó đây:

Mã:

Private Sub CommandButton1_Click()
Dim NoiDung As Range, Vung As Variant, I, K As Long, d As Object, Hang As Long, Tam As Variant, Kq As Variant
    Set d = CreateObject("scripting.dictionary")
    Set NoiDung = Sheets("F").Range(Sheets("F").[BR6], Sheets("F").[BR10000].End(xlUp))
    ReDim Tam(1 To NoiDung.Rows.Count, 1 To 1)
    Vung = Sheets("F").Range(Sheets("F").[AR6], Sheets("F").[AR10000].End(xlUp)).Resize(, 12)
        For Each I In Vung
            If I <> "." Then
                If Not d.exists(I) Then
                    Hang = Application.WorksheetFunction.Match(I, NoiDung, 0)
                    d.Add I, ""
                    Tam(Hang, 1) = I
                End If
            End If
        Next I
            ReDim Kq(1 To NoiDung.Rows.Count, 1 To 1)
            For I = 1 To NoiDung.Rows.Count
                If Tam(I, 1) <> "" Then
                    K = K + 1
                    Kq(K, 1) = Tam(I, 1)
                End If
            Next I
    Sheets("noidung").[D10].Resize(K, 1) = Kq
End Sub

Thân

khamha · 15/5/13

Nếu thể thì khí hậu ở SG và Lào giống nhau rồi,Cũng đang rất nóng nhưng đang đi a lếc anh em nên ko tắm được,ko biết khi nào có cơ hội được đàm tửu với SPCG. ko biết tửu lượng của SP cón chiến đấu được lít ko?

khamha · 15/5/13

Được voi đòi tiên.

concogia đã viết:
Bài này còn nhiều vấn đề chưa hiểu lắm, làm tạm thôi, xỉn quá rồi
Bạn kiểm tra giúp
Thân

Nhờ SPCG phang vào mấy cái Sheet báo cáo để cho nó tự động tính tổng luôn (ko dùng công thức nữa) đã lỡ Code thì cho nó Code hết luôn ,Thank SPCG

Ba Tê · 15/5/13

concogia đã viết:
Híc, tưng quá
Không cần sort đâu bạn già Ba Tê ạ, nên không quan tâm sắp xếp theo kiểu số hay chuỗi. Ta sắp xếp theo bảng dữ liệu cho trước, trong bài là 3 bảng "Nội dung" , "Quy cách", "Bộ phận"
Mỗi người có một cách giải khác nhau, mình thì làm theo kiểu thế này, thí dụ với "Quy cách"
Tạo nút bấm ở sheet "Quycach" ( đây chỉ là ví dụ, bạn có thể chạy code tùy ý) chạy code này:

Mã:

Private Sub CommandButton1_Click() Dim QuyCach As Range, Vung As Variant, I As Long, K As Long, d As Object, Hang As Long, Tam As Variant, Kq As Variant Set d = CreateObject("scripting.dictionary") Set QuyCach = Sheets("F").Range(Sheets("F").[BT6], Sheets("F").[BT10000].End(xlUp)) ReDim Tam(1 To QuyCach.Rows.Count, 1 To 1) Vung = Sheets("F").Range(Sheets("F").[AG6], Sheets("F").[AG10000].End(xlUp)) For I = 1 To UBound(Vung) If Not d.exists(Vung(I, 1)) Then Hang = Application.WorksheetFunction.Match(Vung(I, 1), QuyCach, 0) d.Add Vung(I, 1), "" Tam(Hang, 1) = Vung(I, 1) End If Next I ReDim Kq(1 To QuyCach.Rows.Count, 1 To 1) For I = 1 To QuyCach.Rows.Count If Tam(I, 1) <> "" Then K = K + 1 Kq(K, 1) = Tam(I, 1) End If Next I Sheets("quycach").[D10].Resize(K, 1) = Kq End Sub

Tưng quá, làm một cái thôi, 2 cái còn lại tương tự, riêng mấy cái thằng a1, a2..............phải thêm điều kiện khác dấu chấm (".")
Nếu trúng thì tốt, hổng trúng thì bạn khamha nhờ thầy Ba Tê giúp tiếp nhé, hihi
Híc
Thân

Vậy là tới giờ tui vẫn chưa hiểu câu hỏi.
Híc! Cò Già hay thiệt.

truong84 · 18/5/13

Anh chị thân mến!
Anh chị cho em hỏi. em muốn lọc lấy nội dung công việc theo từng ngày thì làm thế nào được ạ, nhờ anh chị chỉ giúp
em cảm ơn anh chị!View attachment Loc lay noi dung theo ngay.xlsx

Ba Tê · 19/5/13

khamha đã viết:
Nhờ SPCG phang vào mấy cái Sheet báo cáo để cho nó tự động tính tổng luôn (ko dùng công thức nữa) đã lỡ Code thì cho nó Code hết luôn ,Thank SPCG

Bạn muốn "phang" mà phang vào đâu, cột nào, lấy tổng ở đâu, lấy ra sao....
Bạn đưa file mẫu có giải thích và kết quả muốn có lên đi.

Ba Tê · 19/5/13

truong84 đã viết:
Anh chị thân mến!
Anh chị cho em hỏi. em muốn lọc lấy nội dung công việc theo từng ngày thì làm thế nào được ạ, nhờ anh chị chỉ giúp
em cảm ơn anh chị!View attachment 102309

Hỏi kiểu này sao khó hiểu quá.
Bạn cho kết quả bạn muốn có cho ngày 27 vào ô J2 và ngày 28 vào ô J3 xem nó ra sao.

khamha · 21/5/13

Ba Tê đã viết:
Bạn muốn "phang" mà phang vào đâu, cột nào, lấy tổng ở đâu, lấy ra sao....
Bạn đưa file mẫu có giải thích và kết quả muốn có lên đi.

Chà mình sơ xuất quá...đã phạm quy ,mình đã up File muốn "phang"...(những dòng chữ màu xanh,có công thức:là những chỗ muốn thay thế bằng Code) .Thank

khamha · 22/5/13

khamha đã viết:
Chà mình sơ xuất quá...đã phạm quy ,mình đã up File muốn "phang"...(những dòng chữ màu xanh,có công thức:là những chỗ muốn thay thế bằng Code) .Thank

Ko biết hai SPCG & BT "phang" đến đâu rồi ta.

vnlife2000 · 18/2/17

Muốn giữ nguyên định dạng sau khi paste thì phải làm sao ạ?

quanghai1969 đã viết:
Vầy cũng ngắn nè.

PHP:

Sub loc() Dim data(), item data = [A5].Resize(65000, 10).Value With CreateObject("scripting.dictionary") For Each item In data If item <> "" Then If Not .exists(item) Then .Add item, "" End If Next [K5].Resize(.Count) = Application.Transpose(.keys) End With End Sub

PS: Theo kinh nghiệm thì chịu khó dùng 2 lần If, tránh dùng And thì tốc độ cải thiện đáng kể

ndu96081631 · 19/2/17

vnlife2000 đã viết:
Muốn giữ nguyên định dạng sau khi paste thì phải làm sao ạ?

Để giữ nguyên định dạng, không gì bằng ta dùng Advanced Filter

vnlife2000 · 19/2/17

Mình có 2 sheet khác nhau bạn ah, mình có dùng mảng khai báo trong Nam manager nhưng khi chạy rất là chậm, dùng code ở trên chạy rất là nhanh nhưng code trên không giữ định dạng, có cách nào giúp mình code lại không ạ. cảm ơn mọi người.

genius111 · 24/10/17

ndu96081631 đã viết:

Dùng cái này:

Mã:

Function UniqueList(ParamArray sArray())
  Dim Item, tmpArr, SubArr, tmp
  'On Error Resume Next
  With CreateObject("Scripting.Dictionary")
    For Each SubArr In sArray
      tmpArr = SubArr
      If Not IsArray(tmpArr) Then tmpArr = Array(tmpArr)
      For Each Item In tmpArr
        tmp = CStr(Item)
        If Len(tmp) Then
          If Not .Exists(tmp) Then .Add tmp, ""
        End If
      Next
    Next
    If .Count Then UniqueList = .Keys
  End With
End Function
Sub Main()
  Dim Arr
  With Sheet1
    .Range("K5:K10000").ClearContents
    Arr = UniqueList(.Range("A5:J10000"))
    If IsArray(Arr) Then .Range("K5").Resize(UBound(Arr) + 1).Value = WorksheetFunction.Transpose(Arr)
  End With
End Sub

Chạy Sub Main sẽ có kết quả

Thầy Ndu cho em hỏi trường hợp của em là trích lọc duy nhất theo điều kiện sang 1 sheet khác, ví dụ em muốn trích lọc duy nhất các giá trị liên quan đến "Gói 1" thì các dữ liệu liên quan đến "Gói 1" sẽ được trích lọc duy nhất sang sheet khác. Em thử sửa code Main của thầy thành
if Arr = Dkien loc and IsArray(Arr) then .... nhưng mà bị lỗi, em gửi File thầy xem giúp em, em cảm ơn!

genius111 · 24/10/17

hpkhuong đã viết:
Chi khổ vậy. Dùng Advanced Filter trong vòng 3 nốt nhạc cho nhanh!

thanks anh, nhưng vì em mới học về mảng nên muốn luyện thêm, thấy đoạn code của thầy Ndu tuy có hơi dài nhưng có thể vận dụng cho nhiều trường hợp vì chỉ cần sửa sub main là được, cơ mà tư duy em có hạn nên gặp bài toán có hơi thay đổi chút xíu mà chưa xoay sở được

genius111 · 24/10/17

a

hpkhuong đã viết:

Muốn học mảng thì vầy.

Mã:

Public Sub GPE()
Dim Dic As Object, I As Long, K As Long, Tmp As String, Arr, dArr, Goi As String
Arr = Sheet1.Range("A1").CurrentRegion.Value "Vùng dữ liệu nguồn, lấy luôn cả tiêu đề -> tương ứng với chuột đang đặt tại A1 và nhấn Ctrl+Shift+*
ReDim dArr(1 To UBound(Arr), 1 To 1)
Goi = Sheet2.Range("A2").Value
Set Dic = CreateObject("Scripting.Dictionary")
    For I = 2 To UBound(Arr) "Duyệt từ dòng 2 của vùng dữ liệu đến hết.
        If Arr(I, 5) = Goi Then "Nếu cột 5 trong vùng dữ liệu bằng GÓI
        Tmp = Arr(I, 4) 'Cột 4 trong vùng dữ liệu
            If Not Dic.Exists(Tmp) Then
                K = K + 1
                Dic.Add Tmp, K
                dArr(K, 1) = Tmp
            End If
        End If
    Next
With Sheet2
    .Range("A4").Resize(1000).ClearContents
    .Range("A4").Resize(K) = dArr
End With
End Sub

anh ơi, code bị báo lỗi chỗ .Range("A4").Resize(K) = dArr

PacificPR · 24/10/17

genius111 đã viết:
a

anh ơi, code bị báo lỗi chỗ .Range("A4").Resize(K) = dArr

Bạn thay lại là .Range("A4").Resize(K,1) = dArr

genius111 · 24/10/17

PacificPR đã viết:
Bạn thay lại là .Range("A4").Resize(K,1) = dArr

cảm ơn bác nhưng em thay lại rồi mà vẫn bị báo lỗi dòng đó

genius111 · 24/10/17

hpkhuong đã viết:
Không cần thiết vì mảng dArr có 1 cột nhé.

Chữ Gói 01 tại A2 khác với bên dữ liệu. bạn kiểm tra kỹ lại nhé... (copy paste value từ bên dữ liệu sang ô A2 và chạy lại code nhé)

Hix, em sai cơ bản quá, đúng là em gõ sai thật, em cảm ơn bác hpkhuong nhiều

huongmuine · 27/4/18

NHờ các anh chị viết giúp code bằng sự kiện "Private Sub Worksheet_Change"
-Lọc duy nhất và xếp thứ tự theo năm sinh.
- Đếm số lượng trên nữ
Kết quả ở vùng tô vàng.
Xin cảm ơn.

Hỏi về trích lọc dữ liệu duy nhất từ một mảng (1 người xem)

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

Không có việc gì khó...

Cạo Rồi Khỏi Gội

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

Cạo Rồi Khỏi Gội

VBA & VB.NET for Excel & AutoCad

Không có việc gì khó...

File đính kèm

Huyền thoại GPE

Thành viên gắn bó

Không có việc gì khó...

Huyền thoại GPE

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

Thành viên thường trực

File đính kèm

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

Huyền thoại GPE

Không có việc gì khó...

File đính kèm

Cạo Rồi Khỏi Gội

Không có việc gì khó...

Cạo Rồi Khỏi Gội

Huyền thoại GPE

Cạo Rồi Khỏi Gội

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

Không có việc gì khó...

File đính kèm

Huyền thoại GPE

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

Không có việc gì khó...

File đính kèm

Gội rồi mới Cạo

Không có việc gì khó...

File đính kèm

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

Gội rồi mới Cạo

File đính kèm

Không có việc gì khó...

Không có việc gì khó...

File đính kèm

Không có việc gì khó...

Gội rồi mới Cạo

File đính kèm

Không có việc gì khó...

Gội rồi mới Cạo

Không có việc gì khó...

File đính kèm

Cạo Rồi Khỏi Gội

File đính kèm

Không có việc gì khó...

Gội rồi mới Cạo

File đính kèm

Không có việc gì khó...

Gội rồi mới Cạo

Gội rồi mới Cạo

File đính kèm

Không có việc gì khó...

Không có việc gì khó...

Cạo Rồi Khỏi Gội

Thành viên mới

Cạo Rồi Khỏi Gội

Cạo Rồi Khỏi Gội

Không có việc gì khó...

File đính kèm

Không có việc gì khó...

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

Huyền thoại GPE

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

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

File đính kèm

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

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

Thành viên mới

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

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

Thành viên GPE

File đính kèm

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