Code VBA tách chuỗi - So sánh và sắp xếp (1 người xem)

Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
P

Phương Phương mito

Thành viên thường trực
Tham gia
1/5/19
Bài viết
275
Được thích
65
Em có File kèm theo. Tại D5 và D6 em có dữ liệu hàng hóa kèm số lượng được bán của vùng1 và 2. Trong đó Chữ phía trước là mã hàng, số trong ngoặc đơn là số lượng bán. Có Code gì có thể lấy ra, so sánh và List theo yêu cầu lấy ra 5 mã hàng có giá trị lớn nhất của từng vùng (5 mã lớn nhất của từng vùng lấy ra xếp từ lớn đến bé từ B12 và D12 kèm theo là giá trị tương ứng tại C12 và E12). Mỗi mã hàng kèm giá trị là duy nhất ở mỗi vùng - Tức không có mã hàng nào lặp lại 2 lần trong mỗi vùng. Em cảm ơn ạ.
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
khanhly94 đã viết:
Em có File kèm theo. Tại D5 và D6 em có dữ liệu hàng hóa kèm số lượng được bán của vùng1 và 2. Trong đó Chữ phía trước là mã hàng, số trong ngoặc đơn là số lượng bán. Có Code gì có thể lấy ra, so sánh và List theo yêu cầu lấy ra 5 mã hàng có giá trị lớn nhất của từng vùng (5 mã lớn nhất của từng vùng lấy ra xếp từ lớn đến bé từ B12 và D12 kèm theo là giá trị tương ứng tại C12 và E12). Mỗi mã hàng kèm giá trị là duy nhất ở mỗi vùng - Tức không có mã hàng nào lặp lại 2 lần trong mỗi vùng. Em cảm ơn ạ.
Nhấp chuột vào đây để mở rộng...
Thử code này
Mã: 
Option Explicit
Sub Tach_SapXep()
Dim Nguon
Dim Mang0, Mang1
Dim Kq1, Kq2
Dim i, j
Nguon = Sheet1.Range("D5:D6")
ReDim Mang1(1)
Nguon(1, 1) = Split(Replace(Replace(Nguon(1, 1), ")", ""), "(", " "), ",")
For i = 0 To UBound(Nguon(1, 1))
    Mang0 = Split(Nguon(1, 1)(i))
    j = CLng(Mang0(1))
    If UBound(Mang1) < j Then ReDim Preserve Mang1(j)
    Mang1(j) = Mang0
Next i
ReDim Kq1(1 To 5, 1 To 2)
j = 0
For i = UBound(Mang1) To 0 Step -1
    If IsArray(Mang1(i)) = True Then
        j = j + 1
        Kq1(j, 1) = Mang1(i)(0)
        Kq1(j, 2) = Mang1(i)(1)
        If j = 5 Then Exit For
    End If
Next i
ReDim Mang1(1)
Nguon(2, 1) = Split(Replace(Replace(Nguon(2, 1), ")", ""), "(", " "), ",")
For i = 0 To UBound(Nguon(2, 1))
    Mang0 = Split(Nguon(2, 1)(i))
    j = CLng(Mang0(1))
    If UBound(Mang1) < j Then ReDim Preserve Mang1(j)
    Mang1(j) = Mang0
Next i
ReDim Kq2(1 To 5, 1 To 2)
j = 0
For i = UBound(Mang1) To 0 Step -1
    If IsArray(Mang1(i)) = True Then
        j = j + 1
        Kq2(j, 1) = Mang1(i)(0)
        Kq2(j, 2) = Mang1(i)(1)
        If j = 5 Then Exit For
    End If
Next i
Sheet1.Range("B12").Resize(5, 2) = Kq1
Sheet1.Range("D12").Resize(5, 2) = Kq2
End Sub
 
Upvote 0
CHAOQUAY đã viết:
Thử code này
Mã: 
Option Explicit
Sub Tach_SapXep()
Dim Nguon
Dim Mang0, Mang1
Dim Kq1, Kq2
Dim i, j
Nguon = Sheet1.Range("D5:D6")
ReDim Mang1(1)
Nguon(1, 1) = Split(Replace(Replace(Nguon(1, 1), ")", ""), "(", " "), ",")
For i = 0 To UBound(Nguon(1, 1))
    Mang0 = Split(Nguon(1, 1)(i))
    j = CLng(Mang0(1))
    If UBound(Mang1) < j Then ReDim Preserve Mang1(j)
    Mang1(j) = Mang0
Next i
ReDim Kq1(1 To 5, 1 To 2)
j = 0
For i = UBound(Mang1) To 0 Step -1
    If IsArray(Mang1(i)) = True Then
        j = j + 1
        Kq1(j, 1) = Mang1(i)(0)
        Kq1(j, 2) = Mang1(i)(1)
        If j = 5 Then Exit For
    End If
Next i
ReDim Mang1(1)
Nguon(2, 1) = Split(Replace(Replace(Nguon(2, 1), ")", ""), "(", " "), ",")
For i = 0 To UBound(Nguon(2, 1))
    Mang0 = Split(Nguon(2, 1)(i))
    j = CLng(Mang0(1))
    If UBound(Mang1) < j Then ReDim Preserve Mang1(j)
    Mang1(j) = Mang0
Next i
ReDim Kq2(1 To 5, 1 To 2)
j = 0
For i = UBound(Mang1) To 0 Step -1
    If IsArray(Mang1(i)) = True Then
        j = j + 1
        Kq2(j, 1) = Mang1(i)(0)
        Kq2(j, 2) = Mang1(i)(1)
        If j = 5 Then Exit For
    End If
Next i
Sheet1.Range("B12").Resize(5, 2) = Kq1
Sheet1.Range("D12").Resize(5, 2) = Kq2
End Sub
Nhấp chuột vào đây để mở rộng...
Chạy được rồi ạ. ANh cho em hỏi chút về xác định tọa độ ô với ạ. Em chưa hiểu lắm các con số mà em bôi đậm để xác định tọa độ ạ. ANh có thể giải thích dùm em được không ạ. Em cảm ơn ạ.

ReDim Kq1(1 To 5, 1 To 2)
j = 0
For i = UBound(Mang1) To 0 Step -1
If IsArray(Mang1(i)) = True Then
j = j + 1
Kq1(j, 1) = Mang1(i)(0)
Kq1(j, 2) = Mang1(i)(1)
If j = 5 Then Exit For
End If



Mang0 = Split(Nguon(1, 1)(i))
Mang0 = Split(Nguon(2, 1)(i))


ReDim Kq2(1 To 5, 1 To 2)
j = 0
For i = UBound(Mang1) To 0 Step -1
If IsArray(Mang1(i)) = True Then
j = j + 1
Kq2(j, 1) = Mang1(i)(0)
Kq2(j, 2) = Mang1(i)(1)
If j = 5 Then Exit For
End If


Sheet1.Range("B12").Resize(5, 2) = Kq1
Sheet1.Range("D12").Resize(5, 2) = Kq2
 
Upvote 0
khanhly94 đã viết:
Chạy được rồi ạ. ANh cho em hỏi chút về xác định tọa độ ô với ạ. Em chưa hiểu lắm các con số mà em bôi đậm để xác định tọa độ ạ. ANh có thể giải thích dùm em được không ạ. Em cảm ơn ạ.

ReDim Kq1(1 To 5, 1 To 2)
j = 0
For i = UBound(Mang1) To 0 Step -1
If IsArray(Mang1(i)) = True Then
j = j + 1
Kq1(j, 1) = Mang1(i)(0)
Kq1(j, 2) = Mang1(i)(1)
If j = 5 Then Exit For
End If



Mang0 = Split(Nguon(1, 1)(i))
Mang0 = Split(Nguon(2, 1)(i))


ReDim Kq2(1 To 5, 1 To 2)
j = 0
For i = UBound(Mang1) To 0 Step -1
If IsArray(Mang1(i)) = True Then
j = j + 1
Kq2(j, 1) = Mang1(i)(0)
Kq2(j, 2) = Mang1(i)(1)
If j = 5 Then Exit For
End If


Sheet1.Range("B12").Resize(5, 2) = Kq1
Sheet1.Range("D12").Resize(5, 2) = Kq2
Nhấp chuột vào đây để mở rộng...
Mã: 
ReDim Kq2(1 To 5, 1 To 2)
Là khai báo mảng Kq 2 chiều, có 5 dòng & 2 cột. Các dòng & cột bắt đầu từ 1
Mã: 
Kq2(j, 1) = Mang1(i)(0)
Kq2(j, 1) : Ví du j=2 -> mảng Kq2 tại dòng 2, cột 1
Mang1(i)(0) : Mang1 là mang 1 chiều, các phân tử của nó sẽ chứa 1 mảng con, mảng con này có 2 phần tử : phan tu 0=Mã, phan tu 1=giá trị
Kq2(j, 1) = Mang1(i)(0) -> kết qua tại dòng j, côt 1 = mã hang tai phần tư thứ i của Mang1
Mã: 
Sheet1.Range("B12").Resize(5, 2)
Là mở rông ô B12 ra thành 5 dòng 2 cột
 
Upvote 0
CHAOQUAY đã viết:
Mã: 
ReDim Kq2(1 To 5, 1 To 2)
Là khai báo mảng Kq 2 chiều, có 5 dòng & 2 cột. Các dòng & cột bắt đầu từ 1
Mã: 
Kq2(j, 1) = Mang1(i)(0)
Kq2(j, 1) : Ví du j=2 -> mảng Kq2 tại dòng 2, cột 1
Mang1(i)(0) : Mang1 là mang 1 chiều, các phân tử của nó sẽ chứa 1 mảng con, mảng con này có 2 phần tử : phan tu 0=Mã, phan tu 1=giá trị
Kq2(j, 1) = Mang1(i)(0) -> kết qua tại dòng j, côt 1 = mã hang tai phần tư thứ i của Mang1
Mã: 
Sheet1.Range("B12").Resize(5, 2)
Là mở rông ô B12 ra thành 5 dòng 2 cột
Nhấp chuột vào đây để mở rộng...
Em cảm ơn anh nhiều ạ ! Em sẽ học được nhiều thứ từ cái Code này ạ !!!
 
Upvote 0
CHAOQUAY đã viết:
Thử code này
Mã: 
Option Explicit
Sub Tach_SapXep()
Dim Nguon
Dim Mang0, Mang1
Dim Kq1, Kq2
Dim i, j
Nguon = Sheet1.Range("D5:D6")
ReDim Mang1(1)
Nguon(1, 1) = Split(Replace(Replace(Nguon(1, 1), ")", ""), "(", " "), ",")
For i = 0 To UBound(Nguon(1, 1))
    Mang0 = Split(Nguon(1, 1)(i))
    j = CLng(Mang0(1))
    If UBound(Mang1) < j Then ReDim Preserve Mang1(j)
    Mang1(j) = Mang0
Next i
ReDim Kq1(1 To 5, 1 To 2)
j = 0
For i = UBound(Mang1) To 0 Step -1
    If IsArray(Mang1(i)) = True Then
        j = j + 1
        Kq1(j, 1) = Mang1(i)(0)
        Kq1(j, 2) = Mang1(i)(1)
        If j = 5 Then Exit For
    End If
Next i
ReDim Mang1(1)
Nguon(2, 1) = Split(Replace(Replace(Nguon(2, 1), ")", ""), "(", " "), ",")
For i = 0 To UBound(Nguon(2, 1))
    Mang0 = Split(Nguon(2, 1)(i))
    j = CLng(Mang0(1))
    If UBound(Mang1) < j Then ReDim Preserve Mang1(j)
    Mang1(j) = Mang0
Next i
ReDim Kq2(1 To 5, 1 To 2)
j = 0
For i = UBound(Mang1) To 0 Step -1
    If IsArray(Mang1(i)) = True Then
        j = j + 1
        Kq2(j, 1) = Mang1(i)(0)
        Kq2(j, 2) = Mang1(i)(1)
        If j = 5 Then Exit For
    End If
Next i
Sheet1.Range("B12").Resize(5, 2) = Kq1
Sheet1.Range("D12").Resize(5, 2) = Kq2
End Sub
Nhấp chuột vào đây để mở rộng...
Anh cho em nhờ chút với ạ,hiện tại em gặp vấn đề giống #1 nhưng không phải sắp xesp từ lớn->nhỏ mà ngược lại thì code này sẽ chỉnh thế nào ạ ?
 
Upvote 0
ngô đình cẩn đã viết:
Anh cho em nhờ chút với ạ,hiện tại em gặp vấn đề giống #1 nhưng không phải sắp xesp từ lớn->nhỏ mà ngược lại thì code này sẽ chỉnh thế nào ạ ?
Nhấp chuột vào đây để mở rộng...
Bạn tìm các dòng này
Mã: 
For i = UBound(Mang1) To 0 Step -1
Đổi thanh thế này
Mã: 
For i = 0 To UBound(Mang1)
Là kết quả sẽ như ý bạn
 
Upvote 0
CHAOQUAY đã viết:
Bạn tìm các dòng này
Mã: 
For i = UBound(Mang1) To 0 Step -1
Đổi thanh thế này
Mã: 
For i = 0 To UBound(Mang1)
Là kết quả sẽ như ý bạn
Nhấp chuột vào đây để mở rộng...
Kính Anh,
Anh cho em hỏi thêm chút với ạ. Em đang thấy Code chạy đúng với dữ liệu hiện tại có dạng chẳng hạn MM(345). Nghĩa là MM nó liền mạch. Nếu ký tự MM nó chuyển thành dạng bất quy tắc như KK-MM(345), NGUYEN VAN AH - MM(345) thì việc code có khó khăn không ạ. NHờ anh chỉ bảo thêm ạ. Em cảm ơn ạ.
 
Upvote 0
khanhly94 đã viết:
Kính Anh,
Anh cho em hỏi thêm chút với ạ. Em đang thấy Code chạy đúng với dữ liệu hiện tại có dạng chẳng hạn MM(345). Nghĩa là MM nó liền mạch. Nếu ký tự MM nó chuyển thành dạng bất quy tắc như KK-MM(345), NGUYEN VAN AH - MM(345) thì việc code có khó khăn không ạ. NHờ anh chỉ bảo thêm ạ. Em cảm ơn ạ.
Nhấp chuột vào đây để mở rộng...
Nếu giá trị luôn nằm cuối chuỗi thì cũng không quá khó đâu bạn. Bạn gửi 1 vài mẫu lên xem sao
---------
Có thể thử code dưới đây
Mã: 
Option Explicit
Sub Tach_SapXep()
Dim Nguon
Dim Mang0, Mang1
Dim Kq1, Kq2
Dim i, j
Nguon = Sheet1.Range("D5:D6")
ReDim Mang1(1)
'Nguon(1, 1) = Split(Replace(Replace(Nguon(1, 1), ")", ""), "(", " "), ",")
Nguon(1, 1) = Split(Replace(Replace(Nguon(1, 1), ")", ""), "(", "#"), ",")
For i = 0 To UBound(Nguon(1, 1))
    'Mang0 = Split(Nguon(1, 1)(i))
    Mang0 = Split(Nguon(1, 1)(i), "#")
    j = CLng(Mang0(1))
    If UBound(Mang1) < j Then ReDim Preserve Mang1(j)
    Mang1(j) = Mang0
Next i
ReDim Kq1(1 To 5, 1 To 2)
j = 0
For i = UBound(Mang1) To 0 Step -1
    If IsArray(Mang1(i)) = True Then
        j = j + 1
        Kq1(j, 1) = Mang1(i)(0)
        Kq1(j, 2) = Mang1(i)(1)
        If j = 5 Then Exit For
    End If
Next i
ReDim Mang1(1)
'Nguon(2, 1) = Split(Replace(Replace(Nguon(2, 1), ")", ""), "(", " "), ",")
Nguon(2, 1) = Split(Replace(Replace(Nguon(2, 1), ")", ""), "(", "#"), ",")
For i = 0 To UBound(Nguon(2, 1))
    'Mang0 = Split(Nguon(2, 1)(i))
    Mang0 = Split(Nguon(2, 1)(i), "#")
    j = CLng(Mang0(1))
    If UBound(Mang1) < j Then ReDim Preserve Mang1(j)
    Mang1(j) = Mang0
Next i
ReDim Kq2(1 To 5, 1 To 2)
j = 0
For i = UBound(Mang1) To 0 Step -1
    If IsArray(Mang1(i)) = True Then
        j = j + 1
        Kq2(j, 1) = Mang1(i)(0)
        Kq2(j, 2) = Mang1(i)(1)
        If j = 5 Then Exit For
    End If
Next i
Sheet1.Range("B12").Resize(5, 2) = Kq1
Sheet1.Range("D12").Resize(5, 2) = Kq2
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
CHAOQUAY đã viết:
Nếu giá trị luôn nằm cuối chuỗi thì cũng không quá khó đâu bạn. Bạn gửi 1 vài mẫu lên xem sao
---------
Có thể thử code dưới đây
Mã: 
Option Explicit
Sub Tach_SapXep()
Dim Nguon
Dim Mang0, Mang1
Dim Kq1, Kq2
Dim i, j
Nguon = Sheet1.Range("D5:D6")
ReDim Mang1(1)
'Nguon(1, 1) = Split(Replace(Replace(Nguon(1, 1), ")", ""), "(", " "), ",")
Nguon(1, 1) = Split(Replace(Replace(Nguon(1, 1), ")", ""), "(", "#"), ",")
For i = 0 To UBound(Nguon(1, 1))
    'Mang0 = Split(Nguon(1, 1)(i))
    Mang0 = Split(Nguon(1, 1)(i), "#")
    j = CLng(Mang0(1))
    If UBound(Mang1) < j Then ReDim Preserve Mang1(j)
    Mang1(j) = Mang0
Next i
ReDim Kq1(1 To 5, 1 To 2)
j = 0
For i = UBound(Mang1) To 0 Step -1
    If IsArray(Mang1(i)) = True Then
        j = j + 1
        Kq1(j, 1) = Mang1(i)(0)
        Kq1(j, 2) = Mang1(i)(1)
        If j = 5 Then Exit For
    End If
Next i
ReDim Mang1(1)
'Nguon(2, 1) = Split(Replace(Replace(Nguon(2, 1), ")", ""), "(", " "), ",")
Nguon(2, 1) = Split(Replace(Replace(Nguon(2, 1), ")", ""), "(", "#"), ",")
For i = 0 To UBound(Nguon(2, 1))
    'Mang0 = Split(Nguon(2, 1)(i))
    Mang0 = Split(Nguon(2, 1)(i), "#")
    j = CLng(Mang0(1))
    If UBound(Mang1) < j Then ReDim Preserve Mang1(j)
    Mang1(j) = Mang0
Next i
ReDim Kq2(1 To 5, 1 To 2)
j = 0
For i = UBound(Mang1) To 0 Step -1
    If IsArray(Mang1(i)) = True Then
        j = j + 1
        Kq2(j, 1) = Mang1(i)(0)
        Kq2(j, 2) = Mang1(i)(1)
        If j = 5 Then Exit For
    End If
Next i
Sheet1.Range("B12").Resize(5, 2) = Kq1
Sheet1.Range("D12").Resize(5, 2) = Kq2
End Sub
Nhấp chuột vào đây để mở rộng...
Tuyệt quá anh ạ.hi.Cảm ơn anh ạ.
 
Upvote 0
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

Limhachung
Lỗi không copy past excel (1 người xem)
Trả lời
3
Đọc
31
vanle33
vanle33
nguyenhoangtuananh9897
Hỏi về nơi tải danh sách xã huyện tỉnh chuẩn (1 người xem)
2
Trả lời
38
Đọc
3K
3hai
3
vc_đi chơi
Cộng ngày từ sheet này sang sheet khác bị nhảy lung tung (1 người xem)
Trả lời
0
Đọc
21
vc_đi chơi
vc_đi chơi
Phan Thế Hiệp
Tìm ngày giờ kết thúc dự kiến (1 người xem)
    • Thích
    • Yêu thích
Trả lời
15
Đọc
488
VetMini
V
V
Xử lý dữ liệu bị âm
Trả lời
9
Đọc
221
HieuCD
H
Nguyễn Duy Tuân
  • Dán lên cao
Phiên bản mới Add-in A-Tools AI v10 (2024)
    • Thích
2 3
Trả lời
57
Đọc
7K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (5 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
17 18 19
Trả lời
367
Đọc
42K
ngoisaoviet_online
N
K
  • Question Question
Viết code cho file lấy dữ liệu in -out từ bảng chấm công
Trả lời
0
Đọc
52
kimthoa89
K
N
gộp sheet có chứa hình ảnh
Trả lời
1
Đọc
68
thuytrangbp28
T
T
Hướng dẫn kết hợp Drop List và Group PivotTable có điều kiện
Trả lời
6
Đọc
154
thanhphong101
T
N
  • Question Question
Hỗ trợ tiếng việt trong macro
Trả lời
9
Đọc
236
Hoàng Tuấn 868
H
GPE-Trợ Lý
[ĐÀ NẴNG] ĐĂNG KÝ THAM DỰ SINH NHẬT GIAIPHAPEXCEL LẦN THỨ 19 NGÀY 13/07/2025 (1 người xem)
    • Thích
Trả lời
5
Đọc
219
tungnguyen_kt
tungnguyen_kt
OverAC
  • Dán lên cao
  • Suggestion Suggestion
Chúc mừng sinh nhật GiaiPhapExcel 19 tuổi và tặng ebook "Lập trình VBA phần cơ bản." (1 người xem)
    • Thích
    • Yêu thích
Trả lời
3
Đọc
811
PhanTuHuong
PhanTuHuong
GPE-Trợ Lý
[HCM] ĐĂNG KÝ THAM DỰ SINH NHẬT GIAIPHAPEXCEL LẦN THỨ 19 NGÀY 06/07/2025
    • Thích
    • Yêu thích
Trả lời
11
Đọc
956
PhanTuHuong
PhanTuHuong
nguyenthidao2906
cách gộp nhiều file về 1 file trong google sheet (1 người xem)
Trả lời
5
Đọc
968
nguyen thao1712
N
ongke0711
  • Question Question
Vấn đề HttpRequest "Get" trả về Response khác với Reponse thao tác trên trình duyệt
3 4 5
Trả lời
84
Đọc
8K
Huongthu.immanuel@gmail
H
T
Xin mọi người giúp tìm kết quả theo nhiều điều kiện lọc bằng Slicer.
Trả lời
4
Đọc
109
thanhsse
T
K
làm thế nào để in được hàng loạt phiếu lương của nhân viên trong 1 lệnh in
Trả lời
19
Đọc
11K
Hoàng Tuấn 868
H
L
Chuyển font chữ "TRầN VăN THUậN" thành TRẦN VĂN THUẬN
Trả lời
1
Đọc
80
Hoàng Tuấn 868
H
HeSanbi
  • Đã giải quyết
LocalizeXL v1.73 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3 4
Trả lời
78
Đọc
14K
vc_đi chơi
vc_đi chơi
Xem thêm…

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

Sinh nhật lần 19 GPE

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom