Vấn đề sắp xếp hàng trong mảng

[Hoàng Trọng Nghĩa]

Tôi có 1 thủ tục lọc hàng có điều kiện trong mảng:

Private Sub CommandButton1_Click()
    Dim MyArr1, MyArr2, MyItem As Long, MyRow As Long
        LocKhachHang.[A:I].ClearContents
        MyArr1 = KhachHang.Range("B5", KhachHang.[B65536].End(xlUp)).Resize(, 15).Value
        MyRow = UBound(MyArr1, 1)
        ReDim MyArr2(1 To MyRow, 1 To 9)
            [COLOR=#006400]'Giữ tiêu đề ở hàng đầu tiên:[/COLOR]
            MyArr2(1, 1) = MyArr1(1, 1)
            MyArr2(1, 2) = MyArr1(1, 2)
            MyArr2(1, 3) = MyArr1(1, 4)
            MyArr2(1, 4) = MyArr1(1, 5)
            MyArr2(1, 5) = MyArr1(1, 6)
            MyArr2(1, 6) = MyArr1(1, 11)
            MyArr2(1, 7) = MyArr1(1, 8)
            MyArr2(1, 8) = MyArr1(1, 9)
            MyArr2(1, 9) = MyArr1(1, 10)
    For MyItem = 2 To MyRow - 1
       [COLOR=#006400] 'Chuyển dữ liệu từ dưới lên trên:[/COLOR]
        If MyArr1(MyRow + 1 - MyItem, 1) <> "" And MyArr1(MyRow + 1 - MyItem, 15) <> "Thanh Lý" Then
            MyArr2(MyItem, 1) = MyArr1(MyRow + 1 - MyItem, 1)
            MyArr2(MyItem, 2) = MyArr1(MyRow + 1 - MyItem, 2)
            MyArr2(MyItem, 3) = MyArr1(MyRow + 1 - MyItem, 4)
            MyArr2(MyItem, 4) = MyArr1(MyRow + 1 - MyItem, 5)
            MyArr2(MyItem, 5) = MyArr1(MyRow + 1 - MyItem, 6)
            MyArr2(MyItem, 6) = MyArr1(MyRow + 1 - MyItem, 11)
            MyArr2(MyItem, 7) = MyArr1(MyRow + 1 - MyItem, 8)
            MyArr2(MyItem, 8) = MyArr1(MyRow + 1 - MyItem, 9)
            MyArr2(MyItem, 9) = MyArr1(MyRow + 1 - MyItem, 10)
        End If
    Next
    If IsArray(MyArr2) Then LocKhachHang.[A1].Resize(UBound(MyArr2, 1), 9).Value = MyArr2
End Sub

Xin vui lòng cho hỏi các vấn đề sau:

1) Sau khi chạy thủ tục, tại sheet LOC_KH có bị trống 1 số hàng (màu vàng) do lọc theo điều kiện, Vậy làm sao để nó dồn lên trên để không bị trống nữa?

2) Code có thể rút gọn được không?

Xin cám ơn rất nhiều!

 

[ptm0412]

Vụ này GPE cũng nói nhiều rồi:
ReDim Array sau khi đã có dữ liệu , thì mất dữ liệu
ReDim Preserve có thể bảo toàn dữ liệu, nhưng chỉ cho thay đổi kích thước chiều cuối cùng

Cách giải quyết cũng đã có, nhiều bài viết đã áp dụng:
Khai báo mảng xoay ngang, chiều 1 thành 2, 2 thành 1. Dòng thành cột cột thành dòng. Cụ thể là thay vì

ReDim Mg(1 To UBound(Vung), 1 To 2)

thì không khai báo trước kích thước Mg. Trước tiên xét điều kiện.
Khi thoả điều kiện, K = K +1, ReDimPreserve Mg(1 to 2, 1 to K)
Sau đó gán giá trị vào cột K (thay vì dòng K như cũ)

Cuối cùng, transpose Mg để gán xuống sheet, hoặc gán vào cái gì tuỳ ý.

Vụ xoay bảng này cũng có những ý kiến khuyến cáo không nên dùng:

- xoay bảng, rồi ngồi suy luận gán cái gì vào dòng nào cột nào của Array, tay xoay xoay, đầu nghiêng nghiêng, dễ bị tưởng là điên (ẹc ẹc)
- Suy luận sai, tìm không ra chỗ sai, dễ bị tẩu hoả nhập ma
- Transpose cũng có giới hạn của nó, nhiều cột quá không transpose được.
- Tốc độ chậm

 

[concogia]

Sau khi loại bỏ hàng rỗng từ mảng cũ sang mảng mới, vậy tại sao Ubound(NewArray) vẫn bằng Ubound(OldArray)?

Vậy có cách nào để điều chỉnh cho đúng với số hàng đã loại bỏ khoảng trắng không?

Sub MangQuaRacRoi()
    Dim Vung(), Mg(), i As Long, j As Long, K As Long
    [F:G].ClearContents: K = 0
    Vung = Range([A1], [A65536].End(xlUp)).Resize(, 2).Value
    ReDim Mg(1 To UBound(Vung), 1 To 2)
    For i = 1 To UBound(Vung)
        If Vung(i, 2) <> "" Then
            K = K + 1
            For j = 1 To 2
                Mg(K, j) = Vung(i, j)
            Next
        End If
    Next
    MsgBox UBound(Mg, 1)
    [F1].Resize(UBound(Mg, 1), 2).Value = Mg
End Sub

Sử dụng như cách của Thầy Ptm quả là "Phức Văn Tạp". Theo mình, cứ cho nó thêm một vòng lặp nữa là tìm được chính xác số dòng thôi mà, vòng For chạy trong mảng nhanh lắm, không lo về tốc độ đâu:

Sub MangDechRacRoi()
    Dim Vung(), Mg(), i As Long, j As Long, K As Long, M As Long
    [F:G].ClearContents: K = 0
    Vung = Range([A1], [A65536].End(xlUp)).Resize(, 2).Value
    For i = 1 To UBound(Vung)
        If Vung(i, 2) <> "" Then M = M + 1
    Next i
        ReDim Mg(1 To M, 1 To 2)
        For i = 1 To UBound(Vung)
            If Vung(i, 2) <> "" Then
                K = K + 1
                For j = 1 To 2
                    Mg(K, j) = Vung(i, j)
                Next
            End If
        Next
    MsgBox UBound(Mg, 1)
    [F1].Resize(UBound(Mg, 1), 2).Value = Mg
End Sub

Hihi
Một cách khác nếu không muốn thêm vòng lặp

Sub MangDechRacRoi()
Dim Vung(), Mg(), i As Long, j As Long, K As Long
[F:G].ClearContents: K = 0
Vung = Range([A1], [A65536].End(xlUp)).Resize(, 2).Value
ReDim Mg(1 To UBound(Vung) - Range([B1], [B50000].End(xlUp)).SpecialCells(xlCellTypeBlanks).Count, 1 To 2)
For i = 1 To UBound(Vung)
If Vung(i, 2) <> "" Then
K = K + 1
For j = 1 To 2
Mg(K, j) = Vung(i, j)
Next
End If
Next
MsgBox UBound(Mg, 1)
[F1].Resize(UBound(Mg, 1), 2).Value = Mg
End Sub

 

[ptm0412]

Sử dụng như cách của Thầy Ptm quả là "Phức Văn Tạp".

Đúng là phức tạp, mà nếu làm còn dễ bị tẩu hoả nhập ma lắm. Lão chết tiệt bị rồi: Tay quơ quơ chả biết xoay xoay cái gì trước mặt, đầu thì nghiêng nghiêng qua bên trái, miệng lẩm nhẩm hết i, j, k, l rồi lại i, j, l, k, rồi j, i, k, l, ... mấy người chung quanh tưởng điên.

Còn 2 cách của Cò:

Cách 1: Rõ ràng là số vòng lặp tăng gấp đôi, mỗi vòng lặp đều xét 1 cái If, thời gian sẽ ít nhất gấp rưỡi. Chấp nhận được thì cứ xơi.

Cách 2: Dùng SpecialCells(xlCellTypeBlanks) có nguy cơ cao với những ô trống mà không trống, rỗng mà không rỗng:

Ô trống khác với ô công thức trả về rỗng
Ô trống khác với ô rỗng copy từ chỗ khác sang, kể cả paste special value.

 

[ndu96081631]

Cách 2: Dùng SpecialCells(xlCellTypeBlanks) có nguy cơ cao với những ô trống mà không trống, rỗng mà không rỗng:
.

Một rủi ro đáng sợ nhất: Số lượng Areas vượt quá giới hạn cho phép và khi ấy chẳng thể tưởng tượng nỗi điều gì xảy ra (báo lỗi thì khỏe rồi, chỉ sợ nó sẽ lấy tất tần tật, không chừa thứ gì...)
Vụ này bị hoài khi copy sau AutoFilter với dữ liệu lớn
Ẹc... Ẹc...

 

[concogia]

Túm lại, mấycái rắc rối này đều xuất phát từ anh Ếch Xanh cả thôi
Khai báo số dòng của mảng dư tý tẹo

ReDim Mg(1 To UBound(Vung), 1 To 2)

cũng chẳng chết ẻm nào ( khai báo thiếu nó mới la) khi gán kết quả thì:

[F1].Resize(K, 2).Value = Mg

cho nó nhẹ người, khỏi phải "tính đi toán lại" nhức cả đầu
Chán mớ đời anh Ếch Xanh
Híc

 

[ptm0412]

Túm lại, mấycái rắc rối này đều xuất phát từ anh Ếch Xanh cả thôi
... khi gán kết quả thì:
[F1].Resize(K, 2).Value = Mg
cho nó nhẹ người, khỏi phải "tính đi toán lại" nhức cả đầu
Híc

Bài 19 cũng đã đề nghị zậy rồi, nhưng Ếch xanh hỏng chịu. Ếch xanh muốn gắn vào combobox chứ không gắn xuống sheet.