Sắp xếp lấy TOP 4 theo nhiều điều kiện

Liên hệ QC
Em có một file có tô màu liên tiếp theo hàng ngang. mong muốn của e là viết code lấy 01 con số nằm ở ô cuối cùng của hàng đã được tô màu và tách sang cột riêng biệt. Em đã ghi nội dung cần trong file. Kính mong các Anh giúp đỡ.
 

File đính kèm

  • nhờ các Anh viết giùm ak!.xlsx
    10.1 KB · Đọc: 11
tranhoainam9701 đã viết:
Em có một file có tô màu liên tiếp theo hàng ngang. mong muốn của e là viết code lấy 01 con số nằm ở ô cuối cùng của hàng đã được tô màu và tách sang cột riêng biệt. Em đã ghi nội dung cần trong file. Kính mong các Anh giúp đỡ.
Nhấp chuột vào đây để mở rộng...
Thử với code củ chuối này xem sao
Mã: 
Option Explicit

Sub Mau()
Dim i&, j&, t&, Lr, Col&
Dim Rng As Range, Sh As Worksheet
Dim KQ()

Set Sh = Sheet1
Set Rng = Sh.Range("A2").CurrentRegion
Lr = Rng.Rows.Count: Col = Rng.Columns.Count
ReDim KQ(1 To Lr, 1 To Col)
For i = 1 To Lr
t = 0: k = 0
    For j = 1 To Col
        If Rng(i, j) <> Empty Then
            k = k + 1: If Rng(i, j).Interior.Color = vbYellow Then t = t + 1
        Else: Exit For
        End If
    Next j
        If t = 0 Then KQ(i, Col) = Rng(i, k) Else KQ(i, Col - t) = Rng(i, k)
Next i
Sh.[H2].Resize(i - 1, Col) = KQ
End Sub
 
HUONGHCKT đã viết:
Thử với code củ chuối này xem sao
Mã: 
Option Explicit

Sub Mau()
Dim i&, j&, t&, Lr, Col&
Dim Rng As Range, Sh As Worksheet
Dim KQ()

Set Sh = Sheet1
Set Rng = Sh.Range("A2").CurrentRegion
Lr = Rng.Rows.Count: Col = Rng.Columns.Count
ReDim KQ(1 To Lr, 1 To Col)
For i = 1 To Lr
t = 0: k = 0
    For j = 1 To Col
        If Rng(i, j) <> Empty Then
            k = k + 1: If Rng(i, j).Interior.Color = vbYellow Then t = t + 1
        Else: Exit For
        End If
    Next j
        If t = 0 Then KQ(i, Col) = Rng(i, k) Else KQ(i, Col - t) = Rng(i, k)
Next i
Sh.[H2].Resize(i - 1, Col) = KQ
End Sub
Nhấp chuột vào đây để mở rộng...
Cám ơn Các anh! em đã thử chạy code tuy nhiên code báo lỗi ak. Mong các Anh/Chị bớt chút thời gian giúp sửa lại giùm em. nội dung mong muốn e ghi ở trong file ak. Một lần nữa xin chân thành cám ơn các Anh/Chị và xin chúc Anh/ Chị có ngày nghỉ cuối tuần vui vẻ hạnh phúc bên gia đình!
Trân trọng/
 

File đính kèm

  • nhờ các Anh viết giùm ak!.xlsm
    18 KB · Đọc: 2
tranhoainam9701 đã viết:
Cám ơn Các anh! em đã thử chạy code tuy nhiên code báo lỗi ak. Mong các Anh/Chị bớt chút thời gian giúp sửa lại giùm em. nội dung mong muốn e ghi ở trong file ak. Một lần nữa xin chân thành cám ơn các Anh/Chị và xin chúc Anh/ Chị có ngày nghỉ cuối tuần vui vẻ hạnh phúc bên gia đình!
Trân trọng/
Nhấp chuột vào đây để mở rộng...
Bị lỗi ở k=0 đúng không? Do thiếu khai báo biến k
Bạn thêm k&, vào Dòng Dim.... như vầy Dim i&, j&, t&, k&, Lr, Col&
Và chạy thử.
Bạn có thể thêm nhiều dòng, cột nữa cho Dữ liệu (và nhớ là có khoảng trống là 1 cột, 1 dòng với vùng dữ liệu khác) , sau đó nhập vào Ô L1 địa chỉ ô muốn kết quả trả về. và nhấn nút==> xem và kiểm tra kết quả
Xem file đính kèm
 

File đính kèm

  • nhờ các Anh viết giùm ak!.xlsm
    19.8 KB · Đọc: 3
HUONGHCKT đã viết:
Bị lỗi ở k=0 đúng không? Do thiếu khai báo biến k
Bạn thêm k&, vào Dòng Dim.... như vầy Dim i&, j&, t&, k&, Lr, Col&
Và chạy thử.
Bạn có thể thêm nhiều dòng, cột nữa cho Dữ liệu (và nhớ là có khoảng trống là 1 cột, 1 dòng với vùng dữ liệu khác) , sau đó nhập vào Ô L1 địa chỉ ô muốn kết quả trả về. và nhấn nút==> xem và kiểm tra kết quả
Xem file đính kèm
Nhấp chuột vào đây để mở rộng...
thực sự không biết nói gì hơn ngoài lời cảm ơn chân thành tới Anh. Một lần nữa cảm ơn Anh
 
tranhoainam9701 đã viết:
thực sự không biết nói gì hơn ngoài lời cảm ơn chân thành tới Anh. Một lần nữa cảm ơn Anh
Nhấp chuột vào đây để mở rộng...
Em đã sửa code và chạy, tuy nhiên có thêm vấn đề là tại ô A8 không có bôi màu code vẫn sắp xếp và không đếm được số lần mà ô có màu có dữ liệu. Em muốn Anh giúp em code thêm với nội dung e đã ghi trong file gửi đó ak!
Trân trọng/
 

File đính kèm

  • nhờ các Anh viết giùm ak!.xlsm
    19.8 KB · Đọc: 6
tranhoainam9701 đã viết:
Em đã sửa code và chạy, tuy nhiên có thêm vấn đề là tại ô A8 không có bôi màu code vẫn sắp xếp và không đếm được số lần mà ô có màu có dữ liệu. Em muốn Anh giúp em code thêm với nội dung e đã ghi trong file gửi đó ak!
Trân trọng/
Nhấp chuột vào đây để mở rộng...
Sao mình thấy số 32 nằm ở chô khoanh đỏ này có đúng không nhỉ?
Có khi nào có trường hợp ở giữa không bôi màu không nhỉ
1646490390999.png
 
tranhoainam9701 đã viết:
Em đã sửa code và chạy, tuy nhiên có thêm vấn đề là tại ô A8 không có bôi màu code vẫn sắp xếp và không đếm được số lần mà ô có màu có dữ liệu. Em muốn Anh giúp em code thêm với nội dung e đã ghi trong file gửi đó ak!
Trân trọng/
Nhấp chuột vào đây để mở rộng...
Tôi không được tinh anh như người khác. Bạn trình bày rõ hơn được không?
Nghĩa là dòng 8 dữ liệu có 5 ô và không có ô nào được tô màu. Vậy code chạy sẽ lấy dữ liệu của ô nào và điền vào Cột nào (Cột I=5 lần;J=4 lần,...N=0 lần) hay là không lấy ô nào cả.
Nhìn chung là bạn cứ mô tả thật kỹ kết quả mong muốn, có thể giả định kết quả (làm tay) 1-2 trường hợp và upfile lên. Có như vậy nhiều người trên diễn đàn tiếp cận với yêu cầu của bạn họ mới dễ hình dung ra để code giúp bạn chứ (hoặc chí ít thì cũng có thể góp ý hoặc thêm phương án, giải pháp khác...), chứ còn không cứ vừa code vừa đoán ý thì ....
 
BuiQuangThuan đã viết:
Sao mình thấy số 32 nằm ở chô khoanh đỏ này có đúng không nhỉ?
Có khi nào có trường hợp ở giữa không bôi màu không nhỉ
View attachment 272760
Nhấp chuột vào đây để mở rộng...
BuiQuangThuan đã viết:
Sao mình thấy số 32 nằm ở chô khoanh đỏ này có đúng không nhỉ?
Có khi nào có trường hợp ở giữa không bôi màu không nhỉ
View attachment 272760
Nhấp chuột vào đây để mở rộng...
Nhìn chung là mặc dù chưa hiểu hết ý bạn ấy ở đề bài ở #23 tuy nhiên cứ code theo ý hiểu của mình.
Bạn giúp bạn ấy đi, có gí đăng lên cho mình học hỏi thêm
Bài đã được tự động gộp:

BuiQuangThuan đã viết:
Anh lại khiêm tốn quá rồi
Nhấp chuột vào đây để mở rộng...
Tôi nói thật lòng mình mà. nhiều bài tôi cứ ngỡ là mình hiểu ý chủ thớt và nghĩ là làm được. đến khi làm xong định đăng lên trả bài, thì thấy đã có người trả lời, đọc bài và chạy code của họ mới biết mình đã đi sai hướng ==>thuật toán sai==> kết chưa được toàn vẹn.
 
Lần chỉnh sửa cuối:
HUONGHCKT đã viết:
Bạn giúp bạn ấy đi, có gí đăng lên cho mình học hỏi thêm
Nhấp chuột vào đây để mở rộng...
Hihi. Em biết gì đâu anh
Góp vui với code rùa này. chắc tốc độ không bằng mảng được. Áp dụng cho câu đầu. Còn yêu cầu bài 23 em cũng chưa biết thớt muốn gì
Mã: 
Sub ABC()
Dim i&, j&, iR&, iC&, K&
With Sheet1
    .Range("I2:N10000").ClearContents
    iR = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To iR
        K = 0
        iC = .Cells(i, Columns.Count).End(1).Column
        For j = 1 To iC
            If .Cells(i, j) <> Empty Then
                If .Cells(i, j).Interior.Color <> vbYellow Then
                    .Cells(i, 14 - K).Value = .Cells(i, iC).Value
                Else
                    K = K + 1
                End If
            End If
        Next
    Next
End With
End Sub
 
Lần chỉnh sửa cuối:
HUONGHCKT đã viết:
Nhìn chung là mặc dù chưa hiểu hết ý bạn ấy ở đề bài ở #23 tuy nhiên cứ code theo ý hiểu của mình.
Bạn giúp bạn ấy đi, có gí đăng lên cho mình học hỏi thêm
Bài đã được tự động gộp:


Tôi nói thật lòng mình mà. nhiều bài tôi cứ ngỡ là mình hiểu ý chủ thớt và nghĩ là làm được. đến khi làm xong định đăng lên trả bài, thì thấy đã có người trả lời, đọc bài và chạy code của họ mới biết mình đã đi sai hướng ==>thuật toán sai==> kết chưa được toàn vẹn.
Nhấp chuột vào đây để mở rộng...
Dạ thành thật mong hai Anh bỏ qua cho. Do cách hành văn lủng củng nên khó diễn đạt làm phiền đến các Anh nhiều lần. Mong hai Anh giúp thêm lần này ak! Nội dung cụ thể em đã ghi trong file đính kèm ak!
Rất mong sự giúp đỡ của các Anh!
 

File đính kèm

  • nhờ các Anh viết giùm ak!.xlsm
    20.6 KB · Đọc: 4
tranhoainam9701 đã viết:
Dạ thành thật mong hai Anh bỏ qua cho. Do cách hành văn lủng củng nên khó diễn đạt làm phiền đến các Anh nhiều lần. Mong hai Anh giúp thêm lần này ak! Nội dung cụ thể em đã ghi trong file đính kèm ak!
Rất mong sự giúp đỡ của các Anh!
Nhấp chuột vào đây để mở rộng...
Giải thích lòng vòng thêm rối, dựa vào dữ liệu và kết quả trong file
Mã: 
Sub ABC()
  Dim a$(), b$(1 To 1, 1 To 6), rng As Range, sRow&, i&, j&, C&
  Set rng = Sheet1.Range("A4:I" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row)
  sRow = rng.Rows.Count
  ReDim a(1 To sRow, 1 To 6)
  For i = 1 To sRow
    C = 6
    For j = 1 To 8
      If rng(i, j).Interior.Color = vbYellow Then C = C - 1
      If rng(i, j + 1) = Empty Then
        a(i, C) = rng(i, j)
        If InStr(1, b(1, C), a(i, C)) = 0 Then
          If Len(b(1, C)) Then b(1, C) = b(1, C) & "," & a(i, C) Else b(1, C) = a(i, C)
        End If
        Exit For
      End If
    Next j
  Next i
  Range("I2:T10000").Clear
  Sheet1.Range("I4").Resize(sRow, 6) = a
  Sheet1.Range("P2").Resize(, 5) = b
End Sub
Dữ liệu khác có thể tèo
 

File đính kèm

  • nhờ các Anh viết giùm ak!.xlsm
    305.4 KB · Đọc: 8
HieuCD đã viết:
Giải thích lòng vòng thêm rối, dựa vào dữ liệu và kết quả trong file
Mã: 
Sub ABC()
  Dim a$(), b$(1 To 1, 1 To 6), rng As Range, sRow&, i&, j&, C&
  Set rng = Sheet1.Range("A4:I" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row)
  sRow = rng.Rows.Count
  ReDim a(1 To sRow, 1 To 6)
  For i = 1 To sRow
    C = 6
    For j = 1 To 8
      If rng(i, j).Interior.Color = vbYellow Then C = C - 1
      If rng(i, j + 1) = Empty Then
        a(i, C) = rng(i, j)
        If InStr(1, b(1, C), a(i, C)) = 0 Then
          If Len(b(1, C)) Then b(1, C) = b(1, C) & "," & a(i, C) Else b(1, C) = a(i, C)
        End If
        Exit For
      End If
    Next j
  Next i
  Range("I2:T10000").Clear
  Sheet1.Range("I4").Resize(sRow, 6) = a
  Sheet1.Range("P2").Resize(, 5) = b
End Sub
Dữ liệu khác có thể tèo
Nhấp chuột vào đây để mở rộng...
Kính nể, code vùa ngắn mà kết quả như ý.
Tôi cũng đã làm lại cho bạn ấy cũng ra kết quả nhung code hơi dài.
tranhoainam9701 đã viết:
Dạ thành thật mong hai Anh bỏ qua cho. Do cách hành văn lủng củng nên khó diễn đạt làm phiền đến các Anh nhiều lần. Mong hai Anh giúp thêm lần này ak! Nội dung cụ thể em đã ghi trong file đính kèm ak!
Rất mong sự giúp đỡ của các Anh!
Nhấp chuột vào đây để mở rộng...
Bạn thử xem code củ chuối này nhé.
Mã: 
Option Explicit

Sub Mau()
Dim i&, j&, t&, k&, tt&, Lr, Col&
Dim rng As Range, Sh As Worksheet, Ketqua As Range
Dim KQ(), SoLan(), NOI As String
Dim Dic As Object, Key

Set Sh = Sheet1
'Set Ketqua = Sh.[U1]
Set rng = Sh.Range("A4").CurrentRegion
Lr = rng.Rows.Count: Col = rng.Columns.Count
ReDim KQ(1 To Lr, 1 To Col)
For i = 1 To Lr
t = 0: k = 0: NOI = Empty
    For j = 1 To Col
        If rng(i, j) <> Empty Then
            k = k + 1:
            If rng(i, j).Interior.Color = vbYellow Then t = t + 1
            If rng(i, j).Interior.Color <> vbYellow Then
                If NOI = Empty Then NOI = rng(i, j) Else NOI = NOI & ";" & rng(i, j)
            End If
        Else: Exit For
        End If
    Next j
        If t = 0 Then KQ(i, Col) = NOI Else KQ(i, Col - t) = rng(i, k)
Next i
ReDim SoLan(1 To 1, 1 To UBound(KQ))
For i = 1 To UBound(KQ, 2) - 1
Set Dic = CreateObject("Scripting.Dictionary")
    For j = 1 To UBound(KQ, 1)
        If KQ(j, i) <> Empty Then
            Key = KQ(j, i)
            If Not Dic.Exists(Key) Then
            tt = tt + 1: Dic.Add (Key), tt
                If SoLan(1, i) = Empty Then SoLan(1, i) = Key Else SoLan(1, i) = SoLan(1, i) & ";" & Key
            End If
        End If
    Next j
    Set Dic = Nothing
Next i
Sh.[I2].Resize(1, i) = SoLan
Sh.[I4].Resize(Lr, Col) = KQ
End Sub
Khuyên bạn nên sử dụng code của Anh @HieuCD
 
HieuCD đã viết:
Giải thích lòng vòng thêm rối, dựa vào dữ liệu và kết quả trong file
Mã: 
Sub ABC()
  Dim a$(), b$(1 To 1, 1 To 6), rng As Range, sRow&, i&, j&, C&
  Set rng = Sheet1.Range("A4:I" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row)
  sRow = rng.Rows.Count
  ReDim a(1 To sRow, 1 To 6)
  For i = 1 To sRow
    C = 6
    For j = 1 To 8
      If rng(i, j).Interior.Color = vbYellow Then C = C - 1
      If rng(i, j + 1) = Empty Then
        a(i, C) = rng(i, j)
        If InStr(1, b(1, C), a(i, C)) = 0 Then
          If Len(b(1, C)) Then b(1, C) = b(1, C) & "," & a(i, C) Else b(1, C) = a(i, C)
        End If
        Exit For
      End If
    Next j
  Next i
  Range("I2:T10000").Clear
  Sheet1.Range("I4").Resize(sRow, 6) = a
  Sheet1.Range("P2").Resize(, 5) = b
End Sub
Dữ liệu khác có thể tèo
Nhấp chuột vào đây để mở rộng...
Thật là kết quả thật ngoài mong đợi, một lần nữa xin được Cám ơn Anh Hiếu CD và Anh HuongTCKT cũng như All mọi người đã giúp đỡ. Code anh Hiếu em cũng hay vọc trên diễn đàn. Bác hay có sở thích đặt tên sub là ABC. Chúc các Anh một ngày nghỉ cuối tuần vui vẻ bên người thân và gia đình!
Bài đã được tự động gộp:

HUONGHCKT đã viết:
Kính nể, code vùa ngắn mà kết quả như ý.
Tôi cũng đã làm lại cho bạn ấy cũng ra kết quả nhung code hơi dài.

Bạn thử xem code củ chuối này nhé.
Mã: 
Option Explicit

Sub Mau()
Dim i&, j&, t&, k&, tt&, Lr, Col&
Dim rng As Range, Sh As Worksheet, Ketqua As Range
Dim KQ(), SoLan(), NOI As String
Dim Dic As Object, Key

Set Sh = Sheet1
'Set Ketqua = Sh.[U1]
Set rng = Sh.Range("A4").CurrentRegion
Lr = rng.Rows.Count: Col = rng.Columns.Count
ReDim KQ(1 To Lr, 1 To Col)
For i = 1 To Lr
t = 0: k = 0: NOI = Empty
    For j = 1 To Col
        If rng(i, j) <> Empty Then
            k = k + 1:
            If rng(i, j).Interior.Color = vbYellow Then t = t + 1
            If rng(i, j).Interior.Color <> vbYellow Then
                If NOI = Empty Then NOI = rng(i, j) Else NOI = NOI & ";" & rng(i, j)
            End If
        Else: Exit For
        End If
    Next j
        If t = 0 Then KQ(i, Col) = NOI Else KQ(i, Col - t) = rng(i, k)
Next i
ReDim SoLan(1 To 1, 1 To UBound(KQ))
For i = 1 To UBound(KQ, 2) - 1
Set Dic = CreateObject("Scripting.Dictionary")
    For j = 1 To UBound(KQ, 1)
        If KQ(j, i) <> Empty Then
            Key = KQ(j, i)
            If Not Dic.Exists(Key) Then
            tt = tt + 1: Dic.Add (Key), tt
                If SoLan(1, i) = Empty Then SoLan(1, i) = Key Else SoLan(1, i) = SoLan(1, i) & ";" & Key
            End If
        End If
    Next j
    Set Dic = Nothing
Next i
Sh.[I2].Resize(1, i) = SoLan
Sh.[I4].Resize(Lr, Col) = KQ
End Sub
Khuyên bạn nên sử dụng code của Anh @HieuCD
Nhấp chuột vào đây để mở rộng...
code này em sử dụng thấy nó bị sai anh ak? nhảy với cộng số lần sai
 
Lần chỉnh sửa cuối:

File đính kèm

  • code anh hieu.xlsm
    24.1 KB · Đọc: 5
tranhoainam9701 đã viết:
Dạ em xin gửi lại file anh check ak! em comment ở trong file đó ak!
Trân trọng!
Nhấp chuột vào đây để mở rộng...
Đó là nó xếp không đúng với cột tiêu đề thôi. (do số cột lớn nhất là 8 mà số ô có màu trong các dòng lớn nhất là 5. Do vậy Cột lớn nhất - (số ô có màu liên tiếp là 5 +1 Ô không có màu cuối cùng=8) =2 .do vậy khi dán kết quả xuống sheet nó bị chệch 2 cột.
Nghĩ mãi mà không biết làm cách nào.

Có chơi kiểu xếp là Không có màu , 1 lần , 2 ,3,4,5,6....lần không?Số lần ô tô màu trong dòng có thể không hạn chế (10,100, hoặc một số n lần nào đó) ...Nếu xếp theo kiểu như tôi trình bày thì code dễ hơn, chính xác hơn. Bạn thêm dữ liệu, chạy code và kiểm tra lại kết quả Ở I2:...
Nếu trong dải ô ấy có n ô được tô màu và có 1 hoặc 2 ô không được tô màu xen kẽ các ô tô màu thì lấy kết quả thế nào, tính liên tiếp là mấy hay vẫn tính là n lần?
 

File đính kèm

  • code anh hieu.xlsm
    386.5 KB · Đọc: 2
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

Emyeuexcel
  • Question
VBA lưu file, in, và mở lại file gốc ban đầu
Trả lời
8
Đọc
193
Hoàng Tuấn 868
H
O
Kết hợp hàm value
Trả lời
2
Đọc
62
VetMini
V
LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2 3 4
Trả lời
71
Đọc
1K
VetMini
V
P
Nhờ các cao nhân cứu giúp em file excel bị lỗi phần mở rộng
Trả lời
1
Đọc
173
PHNGMINH
P
T
  • Question
Cho mình hỏi tại sao file mình chạy Sao lưu lại bị đầy bộ nhớ.
Trả lời
3
Đọc
103
BuiQuangThuan
B
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom