Xoá hàng theo 2 điều kiện (1 người xem)

[bigbabol89]

Chào các anh, chị !
Rất mong các anh chị giúp đỡ em code VBA để xoá hàng theo 02 điều kiện.
Em có giải thích chi tiết trong file đính kèm.
Em cám ơn.

 

[nghiaphuc]

Chào các anh, chị !
Rất mong các anh chị giúp đỡ em code VBA để xoá hàng theo 02 điều kiện.
Em có giải thích chi tiết trong file đính kèm.
Em cám ơn.

Bạn thử code sau nhé, nhớ lưu dự phòng trước khi chạy code:

Sub XoaDong()
    Dim Rng As Range
    With Sheet2
        If .[A65000].End(xlUp).Row < 2 Then Exit Sub 'Neu vung dieu kien khong co du lieu thi thoat
        Set Rng = .[A1].CurrentRegion 'Vung dieu kien ban dau
        Rng.Copy .[C1] 'Copy qua vung tam de lam DK loc
        .[D2].Resize(Rng.Rows.Count - 1).FormulaR1C1 = "="">=""&RC[-2]" 'Lap cong thuc loc
    End With
    With Sheet1
        .[A1].CurrentRegion.AdvancedFilter xlFilterInPlace, Rng.Offset(, 2) 'Loc du lieu theo DK
        .[A1].CurrentRegion.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete 'Xoa ket qua loc
        .ShowAllData 'Bo loc
    End With
    Rng.Offset(, 2).EntireColumn.Delete 'Xoa vung dieu kien
End Sub

 

[befaint]

Gõ chay bằng điện thoại, chỗ nào lỗi bạn chỉnh nhé.

sub vidu()
Dim a,b,ma as long, mb as long, i as long, j as long, r as long, flag as boolean
Dim res(), d as long, scode as string
a=sheet1.range("a1:b38").value2
b=sheet2.range("a1:b4").value2
ma=ubound(a,1)
mb=ubound(b,1)
Redim res(1 to ma, 1 to 2)
For i=1 to ma
flag=false
scode=a(i,1)
d=clng(val(a(i,2)))
For r=1 to mb
If scode=b(r,1) then
If d>=clng(val(b(r,2))) then
flag = true
Exit for
End if
End if
Next r
If flag = false then
j=j+1
res(j,1)=scode
res(j,2)=a(i,2)
End if
Next i
Sheet1.range("d2").resize(65000,2).clearcontent
If j>0 then sheet1.range("d2").resize(j,2)=res
End sub

 

[phulien1902]

Gõ chay bằng điện thoại, chỗ nào lỗi bạn chỉnh nhé.

sub vidu()
Dim a,b,ma as long, mb as long, i as long, j as long, r as long, flag as boolean
Dim res(), d as long, scode as string
a=sheet1.range("a1:b38").value2
b=sheet2.range("a1:b4").value2
ma=ubound(a,1)
mb=ubound(b,1)
Redim res(1 to ma, 1 to 2)
For i=1 to ma
flag=false
scode=a(i,1)
d=clng(val(a(i,2)))
For r=1 to mb
If scode=b(r,1) then
If d>=clng(val(b(r,2))) then
flag = true
Exit for
End if
End if
Next r
If flag = false then
j=j+1
res(j,1)=scode
res(j,2)=a(i,2)
End if
Next i
Sheet1.range("d2").resize(65000,2).clearcontent
If j>0 then sheet1.range("d2").resize(j,2)=res
End sub

Quá siêu. Thiếu mỗi chữ "s" trong từ ClearContents thôi.

 

[befaint]

Quá siêu. Thiếu mỗi chữ "s" trong từ ClearContents thôi.

Ghép với chữ "u" lần trước được một "su" rồi anh.

 

[bigbabol89]

Gõ chay bằng điện thoại, chỗ nào lỗi bạn chỉnh nhé.

sub vidu()
Dim a,b,ma as long, mb as long, i as long, j as long, r as long, flag as boolean
Dim res(), d as long, scode as string
a=sheet1.range("a1:b38").value2
b=sheet2.range("a1:b4").value2
ma=ubound(a,1)
mb=ubound(b,1)
Redim res(1 to ma, 1 to 2)
For i=1 to ma
flag=false
scode=a(i,1)
d=clng(val(a(i,2)))
For r=1 to mb
If scode=b(r,1) then
If d>=clng(val(b(r,2))) then
flag = true
Exit for
End if
End if
Next r
If flag = false then
j=j+1
res(j,1)=scode
res(j,2)=a(i,2)
End if
Next i
Sheet1.range("d2").resize(65000,2).clearcontent
If j>0 then sheet1.range("d2").resize(j,2)=res
End sub

Anh ơi, em hỏi chút ạ.
- Vùng dữ liệu của em nó to hơn file ví dụ ở cả 2 sheet DS và DK. Có cách nào để mỗi lần chạy code không phải sửa lại vùng chọn không ạ.
- Anh có thể chuyển cho em là kết quả ở sheet mới được không ạ. Vì file kia em chỉ ví dụ có 2 cột ở sheet DS thui, chứ nó nhiều cột lắm.
- Em không biết về macro nhưng em nghĩ cách của anh là copy ra dữ liệu kết quả, nếu số lượng cột ở sheet DS nhiều hơn thì nó cũng chỉ hiện 02 cột A,B.
Em xin lỗi vì file ví dụ chỉ có dữ liệu điều kiện.

 

[befaint]

hỏi chút

Trả lời:
1. Có cách
2. Được
3. Bạn gửi file đang làm lên, mô phỏng thật giống vào.

 

[bigbabol89]

Bạn thử code sau nhé, nhớ lưu dự phòng trước khi chạy code:

Sub XoaDong()
    Dim Rng As Range
    With Sheet2
        If .[A65000].End(xlUp).Row < 2 Then Exit Sub 'Neu vung dieu kien khong co du lieu thi thoat
        Set Rng = .[A1].CurrentRegion 'Vung dieu kien ban dau
        Rng.Copy .[C1] 'Copy qua vung tam de lam DK loc
        .[D2].Resize(Rng.Rows.Count - 1).FormulaR1C1 = "="">=""&RC[-2]" 'Lap cong thuc loc
    End With
    With Sheet1
        .[A1].CurrentRegion.AdvancedFilter xlFilterInPlace, Rng.Offset(, 2) 'Loc du lieu theo DK
        .[A1].CurrentRegion.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete 'Xoa ket qua loc
        .ShowAllData 'Bo loc
    End With
    Rng.Offset(, 2).EntireColumn.Delete 'Xoa vung dieu kien
End Sub

Cám ơn anh. Code chạy rất tốt ạ. A có thể giúp em cho kết quả ở sheet mới được không ạ.

Bài đã được tự động gộp: 7/8/18

Trả lời:
1. Có cách
2. Được
3. Bạn gửi file đang làm lên, mô phỏng thật giống vào.

Hí hí, vậy mai em gửi file nhờ anh giúp nhé. Em không có file mẫu ở nhà.
Em có tìm đọc một số bài ở diễn đàn GPE, em để ý thấy cách viết code của anh rất khác. Kiểu kiểu logic toán học ấy, không biết có phải không