lọc dữ liệu, sắp xếp từ cột thành hàng (1 người xem)

[truonghagpex]

chào các anh chị em hiện đang vướng mắc đoạn code sau mà không tìm được ai giúp, anh chị giúp em làm hộ nhé. em xin cảm ơn nhiều.
EM GỮI KÈM THEO PHAI ĐỂ CÁC ANH XEM HỘ EM NHÉ

 

[salam]

chào các anh chị em hiện đang vướng mắc đoạn code sau mà không tìm được ai giúp, anh chị giúp em làm hộ nhé. em xin cảm ơn nhiều.
EM GỮI KÈM THEO PHAI ĐỂ CÁC ANH XEM HỘ EM NHÉ

Bạn xem trong file kèm nhé.

 

[SA_DQ]

Đây là đoạn Code giành cho bạn

Option Explicit
Sub TimAndCopy()
 Dim Rng As Range, sRng As Range, Clls As Range
 Dim MyColor As Byte, eRw As Long
 
 Sheets("sheet2").Select:        MyColor = [E1].Interior.ColorIndex
 Set Rng = Range([d1], [iV1].End(xlToLeft))
 eRw = [C65500].End(xlUp).Row
 [E2].Resize(eRw, Rng.Columns.Count - 1).ClearContents
 For Each Clls In Range("C2:C" & eRw)
   Set sRng = Rng.Find(Clls.Value, , xlFormulas, xlWhole)
   If sRng Is Nothing Then
      Clls.Interior.ColorIndex = 42 'Tô màu Chung Loai Chua Có'
   Else
      Cells(Clls.Row, sRng.Column).Value = Clls.Offset(, 1).Value
   End If
 Next Clls
 Rng.Offset(, 1).Interior.ColorIndex = IIf(MyColor < 42, MyColor + 1, 34)
End Sub

(Mình mong rằng sẽ không cần đưa file đính kèm lên!)

Chúc bạn thành công!

 

[tam8678]

Option Explicit
Sub TimAndCopy()
 Dim Rng As Range, sRng As Range, Clls As Range
 Dim MyColor As Byte, eRw As Long
 
 Sheets("sheet2").Select:        MyColor = [E1].Interior.ColorIndex
 Set Rng = Range([d1], [iV1].End(xlToLeft))
 eRw = [C65500].End(xlUp).Row
 [E2].Resize(eRw, Rng.Columns.Count - 1).ClearContents
 For Each Clls In Range("C2:C" & eRw)
   Set sRng = Rng.Find(Clls.Value, , xlFormulas, xlWhole)
   If sRng Is Nothing Then
      Clls.Interior.ColorIndex = 42 'Tô màu Chung Loai Chua Có'
   Else
      Cells(Clls.Row, sRng.Column).Value = Clls.Offset(, 1).Value
   End If
 Next Clls
 Rng.Offset(, 1).Interior.ColorIndex = IIf(MyColor < 42, MyColor + 1, 34)
End Sub

(Mình mong rằng sẽ không cần đưa file đính kèm lên!)

Chúc bạn thành công!

---
Em có đọc bài 1 của bạn truonghagpex, nếu em hiểu không sai thì ý tác giả muốn bẻ ngang cột C (từ C2...C) chuyển thành hàng ngang và duy nhất tính từ E1, F1...đồng thời trich số phát sinh giống hình thức bảng kê trong kế toán. File của anh thì hình như tiêu đề E1, F1... là có sẳn. Em không hiểu ý anh lắm, mong anh gởi file đính kèm
Trân trọng.

 

[ndu96081631]

---
Em có đọc bài 1 của bạn truonghagpex, nếu em hiểu không sai thì ý tác giả muốn bẻ ngang cột C (từ C2...C) chuyển thành hàng ngang và duy nhất tính từ E1, F1...đồng thời trich số phát sinh giống hình thức bảng kê trong kế toán. File của anh thì hình như tiêu đề E1, F1... là có sẳn. Em không hiểu ý anh lắm, mong anh gởi file đính kèm
Trân trọng.

Nếu là lọc duy nhất thì trên GPE đã có hàng đóng bài rồi ---> Dùng Dictionary Object là nhanh nhất

 

[sealand]

Mình tham gia cách dùng hàm UDF:

Function Dsach(Rng As Range, Idx As Long) As String
Dim kq
Dim Cll As Range
Dim Ch, Tam As String
Application.Volatile
For Each Cll In Rng.Cells
If InStr(1, Ch, Cll.Text) = 0 Then Ch = Ch & Cll.Text & ";"
Next
Ch = Left(Ch, Len(Ch) - 1)
kq = Split(Ch, ";")
If Idx > UBound(kq) Then Dsach = "": Exit Function
For i = 0 To UBound(kq) - 1
For j = i + 1 To UBound(kq)
Tam = kq(i)
If Tam > kq(j) Then
kq(i) = kq(j)
kq(j) = Tam
End If
Next j, i
Dsach = kq(Idx)
End Function

Cú pháp:
=Dsach(Vùng mã,chỉ số)
Chỉ số bắt đầu từ 0
Ví dụ từ ô C7 bắt đầu Danh sách lập công thức, rồi chép sang các ô khác:

=dsach($A$2:$A$50,COLUMN()-3)

 

[ndu96081631]

Mình tham gia cách dùng hàm UDF:

Function Dsach(Rng As Range, Idx As Long) As String
Dim kq
Dim Cll As Range
Dim Ch, Tam As String
Application.Volatile
For Each Cll In Rng.Cells
If InStr(1, Ch, Cll.Text) = 0 Then Ch = Ch & Cll.Text & ";"
Next
Ch = Left(Ch, Len(Ch) - 1)
kq = Split(Ch, ";")
If Idx > UBound(kq) Then Dsach = "": Exit Function
For i = 0 To UBound(kq) - 1
For j = i + 1 To UBound(kq)
Tam = kq(i)
If Tam > kq(j) Then
kq(i) = kq(j)
kq(j) = Tam
End If
Next j, i
Dsach = kq(Idx)
End Function

Cú pháp:
=Dsach(Vùng mã,chỉ số)
Chỉ số bắt đầu từ 0
Ví dụ từ ô C7 bắt đầu Danh sách lập công thức, rồi chép sang các ô khác:

=dsach($A$2:$A$50,COLUMN()-3)

Lọc duy nhất mà dùng InStr là không ổn đâu anh à!
Ví dụ:
- Vòng lập quét lần đầu tiên ta lấy được phần tử là "abc"
- Vòng lập quét lần 2, nếu phát hiện ra phần tử "ab" hoặc "bc" thì nó sẽ coi như trùng và bỏ qua
Như em đã nói ở trên, Dictionary Object mới là công cụ chuyên làm việc này

 

[tam8678]

Mình tham gia cách dùng hàm UDF:

Cú pháp:
=Dsach(Vùng mã,chỉ số)
Chỉ số bắt đầu từ 0
Ví dụ từ ô C7 bắt đầu Danh sách lập công thức, rồi chép sang các ô khác:

=dsach($A$2:$A$50,COLUMN()-3)

---
- Em tệ quá nên vẫn không hiểu cú pháp nhập chỉ số như thế nào? ( Đã mò mẫm trên file rồi) mong anh nói rõ.
- Em xin hỏi: nếu ra đúng thì mới fản ánh được việc trích cột thành hàng (duy nhất), việc trích ngang số liệu đi theo cột là còn 1 bước nữa fải không?
- Anh lưu ý số liệu nằm trong cột không theo thứ tự và định dạng (số: 710,711), text (712A, 712B)
- Anh cũng làm kế toán thì anh cũng biết việc trích bàn cờ này trong kế toán rất cần.
- Cám ơn anh thật nhiều.

Nếu là lọc duy nhất thì trên GPE đã có hàng đóng bài rồi ---> Dùng Dictionary Object là nhanh nhất

 

[sealand]

To Ndu thân,
Đúng là ý kiến Ndu rất xác đáng và mình bổ xung thêm dùng Dictionary Object.
(Nhưng trong lập trình thì có thể được vì nguyên tắc kỵ trong đặt mã không trùng và không lồng ví dụ A11 và A112. Vấn đề này thường được kiểm tra khi khai báo mã)

Function Dsach2(Rng As Range, Idx As Long) As String
Dim a, tam
Dim Tg As Object
Dim Cll As Range
Application.Volatile
Set Tg = CreateObject("scripting.dictionary")
For Each Cll In Rng.Cells
If Cll.Text <> "" And Not Tg.exists(Cll.Text) Then Tg.Add Cll.Text, Nothing
Next
If Idx > Tg.Count - 1 Then Dsach2 = "": Exit Function
a = Tg.keys
For i = 0 To Tg.Count - 2
For j = i + 1 To Tg.Count - 1
tam = a(i)
If tam > a(j) Then
a(i) = a(j)
a(j) = tam
End If
Next
Next
Dsach2 = a(Idx)
End Function

To Tam 8678 than,
Chi số là số thứ tự của danh sách, ví dụ Idx=2 tức là ta lấy mã thứ 3 trong Dsách mã (Vì chỉ số bắt dầu từ 0).
Bạn gõ công thức =coumn()-3 vào ô nào đó của cột 3 rồi chép qua ô khác cùng dòng xem sao. Mục đích tạo 1 dãy chỉ số chạy: 0;1;2....n. Như vậy, cột C mã thứ nhất, cột D mã thứ 2.... Bạn có thể gõ ô C3
= Dsach2(Vùng,0)
Vùng có thể là cột hay dòng.
Tren Sheet1 minh tao danh sach theo cot doc
Neu sap xep tieng Viet thi chao thua con laij khong ngai dau

(Xin loi tuj nhien khong go duoc dau)

 

[ndu96081631]

---
- Em tệ quá nên vẫn không hiểu cú pháp nhập chỉ số như thế nào? ( Đã mò mẫm trên file rồi) mong anh nói rõ.

Chỉ số có nghĩa là anh cần lấy phần tử thứ mấy trong nguyên cái danh sách duy nhất ấy
Em lấy ví dụ:
- Anh có 1 danh sách lộn xộn (có trùng) gồm 50 phần tử
- Sau khi trích lọc duy nhất, anh được 1 danh sách mới chỉ có 20 phần tử
- Vậy chỉ số ở đây thể hiện rằng anh muốn lấy phần tử thứ mấy trong danh sách 20 phần tử
Anh Sealand dùng hàm Column() là ý muốn công thức này sẽ kéo fill sang phải ---> Nếu có dự định sẽ kéo fill công thức xuống dưới, đương nhiên phải dùng ROW()

 

[ndu96081631]

To Ndu thân,
Đúng là ý kiến Ndu rất xác đáng và mình bổ xung thêm dùng Dictionary Object.
(Nhưng trong lập trình thì có thể được vì nguyên tắc kỵ trong đặt mã không trùng và không lồng ví dụ A11 và A112. Vấn đề này thường được kiểm tra khi khai báo mã)

Function Dsach2(Rng As Range, Idx As Long) As String
Dim a, tam
Dim Tg As Object
Dim Cll As Range
Application.Volatile
Set Tg = CreateObject("scripting.dictionary")
For Each Cll In Rng.Cells
If Cll.Text <> "" And Not Tg.exists(Cll.Text) Then Tg.Add Cll.Text, Nothing
Next
If Idx > Tg.Count - 1 Then Dsach2 = "": Exit Function
a = Tg.keys
For i = 0 To Tg.Count - 2
For j = i + 1 To Tg.Count - 1
tam = a(i)
If tam > a(j) Then
a(i) = a(j)
a(j) = tam
End If
Next
Next
Dsach2 = a(Idx)
End Function

Chỉ cần 1 vòng lập thôi anh à

Function Dsach2(Rng As Range, Idx As Long) As String
  Dim Cll As Range
  With CreateObject("Scripting.Dictionary")
    For Each Cll In Rng.Cells
      If Cll.Text <> "" And Not .Exists(Cll.Text) Then
        .Add Cll.Text, "": Idx = Idx - 1
        If Idx = 0 Then
          Dsach2 = Cll: Exit Function
        End If
      End If
    Next
  End With
End Function

Tức khi vừa lấy được số lượng đúng = Idx thì thoát Function luôn, và khi ấy kết quả chính bằng phần tử vừa Add cuối cùng
(Khi này ta dùng Column()-2)
-------------------------------
Ah... hình như em nhầm thì phải ---> Do UDF của anh có Sort nên thêm vòng lập nữa
Tuy nhiên em nghĩ có lẽ nên làm thêm 1 hàm riêng về sort thì hay hơn, cần Unique + Sort thì lồng vào, không cần thì khỏi xài
Mặc khác, vụ sort này mà đụng tiếng Việt thì lại mệt!

 

[truonghagpex]

cảm ơn mọi người rất nhiều

hỏi mãi các anh và tìm kiếm cuuói cùng em cũng lọc được 2 doạn code của anh ndu và ra được thế này
Sub LOC_VA_SAP_XEP()
Dim vdl As Range
Dim mycell, A, Clls As Range
Dim i, j As Integer
Dim tach As Variant
Dim defaultrang, tg As String
On Error Resume Next
Set vdl = Application.InputBox("CHON VUNG DU LIEU BAN CAN SAP XEP", "HOANG LONG SAP XEP", , , , , , 8)
defaultrang = vdl.Select
Set A = Application.InputBox("CHON O BAT DAU SAP XEP", "HOANG LONG SAP XEP", , , , , , 8)
For Each mycell In vdl.Cells
'mycell = Trim(mycell)
If mycell <> "" Then
If Asc(Trim(mycell)) = 46 Then
'tach = mycell.Address
Range(mycell.Address).Select
'MsgBox "NHUNG O KHONG DUA LEN LA " & tach
'là những ô mà bắt đầu bằng dấu (.)
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Bold = True
.Interior.ColorIndex = 43
.Font.ColorIndex = 5
End With
End If
End If
Next mycell
tg = JointUnique(vdl)
tg = StrSort(tg)
tach = Split(tg, "@")
defaultrang = A.Select
For i = 1 To UBound(tach) + 1
ActiveCell(1, i).Font.Bold = True
ActiveCell(1, i).HorizontalAlignment = xlCenter
ActiveCell(1, i).VerticalAlignment = xlCenter
ActiveCell(1, i) = tach(i - 1)
For j = 2 To vdl.Count
ActiveCell(j, i).Value = "=IF(activecell(1,i).value=activecell(j-i-3).value,activecell(j-i-1),""-"")"
Next j
Next i
'ActiveCell(J, I).Value = "=IF(hoanglongss(r9c3)=hoanglongss(r5c6),(r9c5),""-"")"
'ActiveCell(1, 2) = VDL.Count
'ActiveCell(1, 1).Font.Color = vbRed
canceled:
ActiveCell(2, i - i - 2).Select
End Sub

Function JointUnique(Range As Range, Optional Sep As String = "@") As String
Dim Dic, Clls As Range
On Error Resume Next
With CreateObject("Scripting.Dictionary")
For Each Clls In Range
If (Clls) <> "" Then
If Asc(Trim(Clls)) <> 46 Then
Clls.Value = Trim(Clls)
.Add Clls.Value, ""
End If
End If
Next Clls
JointUnique = Join(.Keys, Sep)
End With
End Function
tuy nhiên cái khó ở sub này là: làm sao để lồng được hàm hoanglongss vào trong công thức gán hàm if khi đó nó mới cho kết quả đúng mà phải lấy địa chỉ từ 2 hàm inputbox nói trên. nếu ai có ý kiến hay đoạn code nào thì chỉ giúp em với để hoàn thiện sub lọc và tính toán