Code VBA Xóa dòng theo điều kiện dùng AutoFilter (1 người xem)

  • Thread starter Thread starter NQ_AT
  • Ngày gửi Ngày gửi
Elx 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)
N

NQ_AT

Thành viên chính thức
Tham gia
9/12/14
Bài viết
68
Được thích
9
Xin chào anh chị

Hiện tại em đang dùng 2 code sau để xóa các dòng thỏa điều kiện, nhưng vừa rồi form của em tới hơn 4k dòng thì phải mất gần 30P mới thực hiện xong. Em đã test thử, nếu chỉ cho xóa cột thôi thì chạy ok, nhưng để phần xóa dòng này vào thì ôi lâu quá.
Nhờ anh chị xem giúp em có cách nào chạy nhanh hơn không nha.
1- Code 1:
PHP: 
Sub Delete()
    Dim Cll As Range, lR As Long
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False: .Calculation = xlCalculationManual: .EnableEvents = False
    End With
    On Error Resume Next
    ThisWorkbook.Save
    With Sheets("Sheet1")
        lR = .Cells.Find("*", , , , , xlPrevious).Row 'Xac dinh dong cuoi'
        .Range("A8:S" & lR).Value = .Range("A8:S" & lR).Value 'Chuyen thanh gia tri',khong co cong thuc
        .[B:B,E:E,H:T,W:X].Delete 'Xoa cac cot theo yeu cau'
        .Range("D8:D" & lR).AutoFilter 'Tat che do loc
        .Range("D8:D" & lR).AutoFilter 1, "PW*" 'Loc cac dong co gia tri PW
        .Range("D9:D" & lR).SpecialCells(12).EntireRow.Delete 'Xoa ket qua loc
        .Range("D8:D" & lR).AutoFilter 'Tat che do loc
    End With
       ThisWorkbook.SaveAs Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 5) & "-TEST.xlsx", 51 'Luu mot ban sao khong chua Macro'
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .EnableEvents = True
    End With
End Sub
2- Code thứ 2:
PHP: 
Sub Delete1()
   Dim Cll As Range, lR As Long
   With Application
       .ScreenUpdating = False: .DisplayAlerts = False: .Calculation = xlCalculationManual: .EnableEvents = False
   End With
   On Error Resume Next
   ThisWorkbook.Save
   With Sheets("Sheet1")
       .Range("A8", .[S10000].End(xlUp)).Value = .Range("A8", .[S10000].End(xlUp)).Value 'Chuyen thanh gia tri',khong co cong thuc        .[B:B,E:E,H:T,W:X].Delete 'Xoa cac cot theo yeu cau'
        .Range("D8", .[D10000].End(xlUp)).AutoFilter 'Tat che do loc
        .Range("D8", .[D10000].End(xlUp)).AutoFilter 1, "PW*" 'Loc cac dong co gia tri PW
        .Range("D9", .[D10000].End(xlUp)).SpecialCells(12).EntireRow.Delete 'Xoa ket qua loc
        .Range("D8", .[D10000].End(xlUp)).AutoFilter 'Tat che do loc
    End With
       ThisWorkbook.SaveAs Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 5) & "-TEST1.xlsx", 51 'Luu mot ban sao khong chua Macro'
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .EnableEvents = True
    End With
End Sub
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Có phải bản muốn xóa những dòng có giá trị PW*?? sao không dùng vòng lặp duyệt từ dưới lên trên rồi xóa rẹt 1phát, sao phải filter làm gì?
 
Upvote 0
Cá ngừ F1 đã viết:
Có phải bản muốn xóa những dòng không có giá trị PW*?? sao không dùng vòng lặp duyệt từ dưới lên trên rồi xóa rẹt 1phát, sao phải filter làm gì?
Nhấp chuột vào đây để mở rộng...
Ý của em là xóa những dòng có chứa giá trị PW* ( có thể là PW, PW1, PW2 ......)
Về Vòng lặp thì a hướng dẫn giúp nha, vì em chưa hình dung ra.
 
Upvote 0
NQ_AT đã viết:
Ý của em là xóa những dòng có chứa giá trị PW* ( có thể là PW, PW1, PW2 ......)
Về Vòng lặp thì a hướng dẫn giúp nha, vì em chưa hình dung ra.
Nhấp chuột vào đây để mở rộng...
Bạn thử đoạn code này xem có cải thiện hơn không:
Mã: 
Sub XoaDong()
    Dim x As Long, y As Long
    With Sheets("sheet1")
        ' Xac dinh dong cuoi cung
        x = .[B65000].End(3).Row
        
        For y = x To 9 Step -1
            If UCase(.Cells(y, 6)) Like "PW*" Then .Cells(y, 6).EntireRow.Delete
        Next
        
    End With
End Sub
 
Upvote 0
NQ_AT đã viết:
Ý của em là xóa những dòng có chứa giá trị PW* ( có thể là PW, PW1, PW2 ......)
Về Vòng lặp thì a hướng dẫn giúp nha, vì em chưa hình dung ra.
Nhấp chuột vào đây để mở rộng...
Code này chỉ xoá dòng, chưa có xoá cột.
PHP: 
Sub XoaDong()
Dim arr(), i, j, k, kq()
arr = Sheet1.[B8].CurrentRegion.Value
ReDim kq(1 To UBound(arr), 1 To UBound(arr, 2))
For i = 1 To UBound(arr)
   If Not arr(i, 6) Like "PW" & "*" Then
      k = k + 1
      For j = 1 To UBound(arr, 2)
         kq(k, j) = arr(i, j)
      Next
   End If
Next
Sheet1.[A7].Resize(i - 1, j - 1) = kq
End Sub
 
Upvote 0
quanghai1969 đã viết:
Code này chỉ xoá dòng, chưa có xoá cột.
PHP: 
Sub XoaDong()
Dim arr(), i, j, k, kq()
arr = Sheet1.[B8].CurrentRegion.Value
ReDim kq(1 To UBound(arr), 1 To UBound(arr, 2))
For i = 1 To UBound(arr)
   If Not arr(i, 6) Like "PW" & "*" Then
      k = k + 1
      For j = 1 To UBound(arr, 2)
         kq(k, j) = arr(i, j)
      Next
   End If
Next
Sheet1.[A7].Resize(i - 1, j - 1) = kq
End Sub
Nhấp chuột vào đây để mở rộng...
Anh Hải truyền báthực phẩm chức năng Current Regiontrong trường hợp này có vẻ hơi NGUY HIỂM. --=0
 
Upvote 0
quanghai1969 đã viết:
Ai biết đâu. Cứ thấy sao mần vậy thôi. Khi nào trật thì chủ thớt ráng chịu. Mình không có chịu à nghen.
Nhấp chuột vào đây để mở rộng...

Cái này sao giống đưa súng cho con nít chơi quá anh Hải, bắn ai ráng chịu. hjhjhj

Cảm ơn các anh, để Test từng súng đã rồi sẽ quay lại trình diện trước pháp luật. :)
 
Upvote 0
Sau khi test xong em có kết quả như sau:

- Code của anh Cá ngừ F1: Code này chạy rất lâu, theo em hiểu thì code này chưa chắc đã nhanh hơn cái autofilter, vì của anh nó phải duyệt từng dòng, dòng nào thỏa thì xóa, dữ liệu 4000 dòng như thế thì quá lâu.
- Code của anh quanghai1969: Hiện tại em vẫn chưa chạy được, Chạy lên nó quay vòng khoảng 5s, sau đó xong, tưởng xong thật mừng quá trời nhưng nhìn lại nó ko thay đổi gì cả. :(
Nhờ các anh xem lại giúp nha.
 
Upvote 0
NQ_AT đã viết:
Ý của em là xóa những dòng có chứa giá trị PW* ( có thể là PW, PW1, PW2 ......)
Về Vòng lặp thì a hướng dẫn giúp nha, vì em chưa hình dung ra.
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub XoaDong()
Dim arr(), i, j, k, kq()
With Sheet1
arr = .Range(.[B9], .[B65000].End(xlUp)).Resize(, 10).Value2
End With
ReDim kq(1 To UBound(arr), 1 To UBound(arr, 2))
For i = 1 To UBound(arr)
   If Not arr(i, 5) Like "PW" & "*" Then
      k = k + 1
      For j = 1 To UBound(arr, 2)
         kq(k, j) = arr(i, j)
      Next
   End If
Next
Sheet1.[A15].Resize(i - 1, j - 1) = kq
End Sub
Bạn thử vậy xem được ko
 
Lần chỉnh sửa cuối:
Upvote 0
comet_1701 đã viết:
Mã: 
Sub XoaDong()
Dim arr(), i, j, k, kq()
With Sheet1
arr = .Range(.[B9], .[B65000].End(xlUp)).Resize(, 10).Value2
End With
ReDim kq(1 To UBound(arr), 1 To UBound(arr, 2))
For i = 1 To UBound(arr)
   If Not arr(i, 5) Like "PW" & "*" Then
      k = k + 1
      For j = 1 To UBound(arr, 2)
         kq(k, j) = arr(i, j)
      Next
   End If
Next
Sheet1.[A15].Resize(i - 1, j - 1) = kq
End Sub
Bạn thử vậy xem được ko
Nhấp chuột vào đây để mở rộng...
Code chạy rồi đó anh, rất nhanh, nhưng không đúng ý em.
Em thấy code này giống như copy nhưng loại trừ những dòng có PW*, sau đó Paste lại đúng không anh.>>> Như thế sẽ bể form hết.
Em chỉ muốn thực hiện Delete các dòng có chữ PW* thôi. ( Giống như thực hiện = tay thì khi xóa nó tự rút dòng lên, Form vẫn như cũ)
 
Upvote 0
NQ_AT đã viết:
Code chạy rồi đó anh, rất nhanh, nhưng không đúng ý em.
Em thấy code này giống như copy nhưng loại trừ những dòng có PW*, sau đó Paste lại đúng không anh.>>> Như thế sẽ bể form hết.
Em chỉ muốn thực hiện Delete các dòng có chữ PW* thôi. ( Giống như thực hiện = tay thì khi xóa nó tự rút dòng lên, Form vẫn như cũ)
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub XoaDong()
Dim arr(), i, j, k, kq()
With Sheet1
arr = .Range(.[B9], .[B65000].End(xlUp)).Resize(, 10).Value2
End With
ReDim kq(1 To UBound(arr), 1 To UBound(arr, 2))
For i = 1 To UBound(arr)
   If Not arr(i, 5) Like "PW" & "*" Then
      k = k + 1
      For j = 1 To UBound(arr, 2)
         kq(k, j) = arr(i, j)
      Next
   End If
Next
Sheet1.[B9:K5000].ClearContents
Sheet1.[B9].Resize(i - 1, j - 1) = kq
End Sub
Bạn thử thế này xem có được ko . Đại ca Quang Hải lên rồi đó, để anh xử lý tiếp bạn nhá
 
Upvote 0
comet_1701 đã viết:
Mã: 
Sub XoaDong()
Dim arr(), i, j, k, kq()
With Sheet1
arr = .Range(.[B9], .[B65000].End(xlUp)).Resize(, 10).Value2
End With
ReDim kq(1 To UBound(arr), 1 To UBound(arr, 2))
For i = 1 To UBound(arr)
   If Not arr(i, 5) Like "PW" & "*" Then
      k = k + 1
      For j = 1 To UBound(arr, 2)
         kq(k, j) = arr(i, j)
      Next
   End If
Next
Sheet1.[B9:K5000].ClearContents
Sheet1.[B9].Resize(i - 1, j - 1) = kq
End Sub
Bạn thử thế này xem có được ko . Đại ca Quang Hải lên rồi đó, để anh xử lý tiếp bạn nhá
Nhấp chuột vào đây để mở rộng...
Rất xin lỗi, bữa giờ em đi công tác chưa test được, ý tưởng này rất hay đó anh, nhưng nếu nó copy luôn cả Format rồi sao đó paste lại có luôn format đó thì rất tuyệt.

Anh xem có cách nào không nha.
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn thử cách này xem. Tuy không nhanh bằng cách dùng mảng của quanghai nhưng theo đúng ý của bạn là như làm thủ công và có thể nhanh hơn cách dùng vòng lặp.
Mã: 
Sub xxx()
    Application.ScreenUpdating = False:
    With Range([f10], [f65000].End(3))
        .Replace "PW*", "", 2
        .SpecialCells(4).EntireRow.Delete
    End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
TrungChinhs đã viết:
Bạn thử cách này xem. Tuy không nhanh bằng cách dùng mảng của quanghai nhưng theo đúng ý của bạn là như làm thủ công và có thể nhanh hơn cách dùng vòng lặp.
Mã: 
Sub xxx()
    Application.ScreenUpdating = False:
    With Range([f10], [f65000].End(3))
        .Replace "PW*", "", 2
        .SpecialCells(4).EntireRow.Delete
    End With
End Sub
Nhấp chuột vào đây để mở rộng...

Vẫn quá lâu anh ơi, nhưng sao e thấy những dòng nào trống cột F thì nó cũng xóa luôn ah.
Em thấy code của anh quanghai rất hay,,chạy quá nhanh, nhưng vì ko rành mảng nên bó tay không biết làm thế nào để nó copy luôn format.
Trên ý tưởng của anh quanghai, e đang tìm cách viết theo Range trước không biết có được không nữa.
 
Upvote 0
NQ_AT đã viết:
Vẫn quá lâu anh ơi, nhưng sao e thấy những dòng nào trống cột F thì nó cũng xóa luôn ah.
Em thấy code của anh quanghai rất hay,,chạy quá nhanh, nhưng vì ko rành mảng nên bó tay không biết làm thế nào để nó copy luôn format.
Trên ý tưởng của anh quanghai, e đang tìm cách viết theo Range trước không biết có được không nữa.
Nhấp chuột vào đây để mở rộng...
Bạn đưa cái file thật lên và muốn giữ form lại thế nào mình xem thử. Cái file đính kèm thấy có form gì đâu mà sợ bể.
 
Upvote 0

File đính kèm

Upvote 0
NQ_AT đã viết:
Dạ, em gửi anh Hải, nhờ anh xem giúp em nha. cần xóa mất các dòng PW*

Cảm ơn anh rất nhiều.
Nhấp chuột vào đây để mở rộng...
Với file đính kèm của bài 17 thì thế này là được.
PHP: 
Sub Xoa()
Dim arr(), i, rng As Range
arr = [A8].CurrentRegion.Value
Set rng = Cells(65536, 1)
For i = UBound(arr) To 1 Step -1
   If arr(i, 6) Like "PW" & "*" Then
      Set rng = Union(rng, Cells(i + 7, 1))
   End If
Next
rng.EntireRow.Delete
End Sub
 
Upvote 0
quanghai1969 đã viết:
Với file đính kèm của bài 17 thì thế này là được.
PHP: 
Sub Xoa()
Dim arr(), i, rng As Range
arr = [A8].CurrentRegion.Value
Set rng = Cells(65536, 1)
For i = UBound(arr) To 1 Step -1
   If arr(i, 6) Like "PW" & "*" Then
      Set rng = Union(rng, Cells(i + 7, 1))
   End If
Next
rng.EntireRow.Delete
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh Hải nhiều, nhưng code này chạy trên file #17 rất nhanh vì chỉ có 3 hạng mục (STT) với hơn 100 dòng, em nhân số lượng dòng lên khoảng 3k (khoang STT 80) mà 25p rồi chưa xong anh ơi.

Em thấy delete có vẽ không ổn đâu anh Hải, chắc phải dùng phương pháp copy rồi paste lại như của anh lúc trước mới nhanh được.
 
Upvote 0
Bạn dùng cái này thử xem
Mã: 
Sub Xoa()
Dim eR As Long, k As Long
Dim Cls As Range
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
eR = Range("A65536").End(3).Row
For Each Cls In Range("F10", Cells(eR, 6))
    If Cls Like "PW*" Then
        k = k + 1
        Cls.Offset(, 17) = ""
    Else
        Cls.Offset(, 17) = 1
    End If
Next
If k Then
    Range("W10", Cells(eR, 23)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
    Range("W10", Cells(eR, 23)).ClearContents


Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
 
Upvote 0
dhn46 đã viết:
Bạn dùng cái này thử xem
Mã: 
Sub Xoa()
Dim eR As Long, k As Long
Dim Cls As Range
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
eR = Range("A65536").End(3).Row
For Each Cls In Range("F10", Cells(eR, 6))
    If Cls Like "PW*" Then
        k = k + 1
        Cls.Offset(, 17) = ""
    Else
        Cls.Offset(, 17) = 1
    End If
Next
If k Then
    Range("W10", Cells(eR, 23)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
    Range("W10", Cells(eR, 23)).ClearContents


Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ cảm ơn anh dhn46, nhưng vẫn chậm lắm anh ơi,

Em xin bổ sung file lại 2k dòng, có thể do file kia em gửi ít dòng quá nên các anh khó test. vì file của em không cố định, lúc thì khoảng hơn 100 dòng lúc thì tới 5K dòng.
 

File đính kèm

Upvote 0
NQ_AT đã viết:
Dạ cảm ơn anh dhn46, nhưng vẫn chậm lắm anh ơi,

Em xin bổ sung file lại 2k dòng, có thể do file kia em gửi ít dòng quá nên các anh khó test. vì file của em không cố định, lúc thì khoảng hơn 100 dòng lúc thì tới 5K dòng.
Nhấp chuột vào đây để mở rộng...
Cách thì có đó, nhưng phải đợi thèm thật là thèm thì ăn mới ngon. Bảo đảm với 2k dòng xóa trong 1 cái chớp mắt. Nhưng giờ chưa hứng đưa code lên. Để cho thèm coi chơi. ka ka ka.
Bài này mà anh Ba Tê nhào vô là xong lâu rồi. Bớ anh Ba Tê ơi..........?
 
Upvote 0
quanghai1969 đã viết:
Cách thì có đó, nhưng phải đợi thèm thật là thèm thì ăn mới ngon. Bảo đảm với 2k dòng xóa trong 1 cái chớp mắt. Nhưng giờ chưa hứng đưa code lên. Để cho thèm coi chơi. ka ka ka.
Bài này mà anh Ba Tê nhào vô là xong lâu rồi. Bớ anh Ba Tê ơi..........?
Nhấp chuột vào đây để mở rộng...
Hic, Nghe anh Hải nói mà thèm chảy nước miếng luôn. 2k dòng mà trong chớp mắt thì bá đạo thật. -+*/@$@!^%
 
Upvote 0
NQ_AT đã viết:
Hic, Nghe anh Hải nói mà thèm chảy nước miếng luôn. 2k dòng mà trong chớp mắt thì bá đạo thật. -+*/@$@!^%
Nhấp chuột vào đây để mở rộng...

Có gì đâu, 5K cũng nhanh chớp luôn, bạn hãy quay lại chính bài #1 của bạn đó, đặt vấn đề lại là bạn cần gì (?) , hãy nghĩ khác xoá đi,

Còn file mà 5K với cách format và số liệu như của bạn, thì bạn thử xoá tay 1 dòng cũng thấy chậm, nói gì xoá nhiều dòng
 
Lần chỉnh sửa cuối:
Upvote 0
NQ_AT đã viết:
Hic, Nghe anh Hải nói mà thèm chảy nước miếng luôn. 2k dòng mà trong chớp mắt thì bá đạo thật. -+*/@$@!^%
Nhấp chuột vào đây để mở rộng...
Giải nén file đính kèm. Chạy file để đăng ký VBA. Copy code này vào file cần xoá dòng và chạy thử.
PHP: 
Public Sub Main()
Dim arr()
arr = Range("F10", [F65536].End(3)).Value
With CreateObject("VBAVBA.vbsub")
   Set .ExcelApp = Application
   .DeleteRow arr
End With
End Sub
 

File đính kèm

Upvote 0
quanghai1969 đã viết:
Giải nén file đính kèm. Chạy file để đăng ký VBA. Copy code này vào file cần xoá dòng và chạy thử.
PHP: 
Public Sub Main()
Dim arr()
arr = Range("F10", [F65536].End(3)).Value
With CreateObject("VBAVBA.vbsub")
   Set .ExcelApp = Application
   .DeleteRow arr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Em mới thử test nó chớp phát xong rồi....File ra Anh cho khi Open lên thì nó chạy thẳng một phát vào luôn mới hay|||||khởi phải thêm một động tác chọn install
 
Lần chỉnh sửa cuối:
Upvote 0
quanghai1969 đã viết:
Giải nén file đính kèm. Chạy file để đăng ký VBA. Copy code này vào file cần xoá dòng và chạy thử.
PHP: 
Public Sub Main()
Dim arr()
arr = Range("F10", [F65536].End(3)).Value
With CreateObject("VBAVBA.vbsub")
   Set .ExcelApp = Application
   .DeleteRow arr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Anh Hải có chiêu gì mới mà LẠ quá trời.}}}}}
 
Upvote 0
quanghai1969 đã viết:
Đây gọi là chiêu "Động não đại pháp". Luyện món này nhức đầu thiệt.
Nhấp chuột vào đây để mở rộng...
Em cảm ơn anh Hải rất nhiều, nhưng em chạy bị lỗi anh Hải ơi "Activex component can't creat object".em giải nén lần nữa thì thấy trong system32 đã có file VBA.dll rồi. Anh xem hình bên dưới nha.

Activex Error.jpg
 
Lần chỉnh sửa cuối:
Upvote 0
NQ_AT đã viết:
Em cảm ơn anh Hải rất nhiều, nhưng em chạy bị lỗi anh Hải ơi "Activex component can't creat object".em giải nén lần nữa thì thấy trong system32 đã có file VBA.dll rồi. Anh xem hình bên dưới nha.

View attachment 136382
Nhấp chuột vào đây để mở rộng...
Bạn đọc bài 26 đi. Người ta đã chạy thử và đã OK tức là code hoạt động tốt. Bạn có làm đúng hướng dẫn của bài 25 chưa? Giải nén file đính kèm. Chạy file này trước để đăng ký VBA.
 
Upvote 0
quanghai1969 đã viết:
Bạn đọc bài 26 đi. Người ta đã chạy thử và đã OK tức là code hoạt động tốt. Bạn có làm đúng hướng dẫn của bài 25 chưa? Giải nén file đính kèm. Chạy file này trước để đăng ký VBA.
Nhấp chuột vào đây để mở rộng...
Đã chạy rồi anh Hải ơi, chạy nó giải nén file VBA.dll vào systems32. Hay là do em dùng windows 64bit nên không chạy được.-+*/
 
Upvote 0
NQ_AT đã viết:
Đã chạy rồi anh Hải ơi, chạy nó giải nén file VBA.dll vào systems32. Hay là do em dùng windows 64bit nên không chạy được.-+*/
Nhấp chuột vào đây để mở rộng...
Tìm xem trong trong C:\Windows\SysWOW64 có file VBAVBA.dll chưa. Nếu chưa có thì copy thủ công vào. Sau đó thử chạy file này. Nhớ là phải Run as...
 

File đính kèm

Upvote 0
quanghai1969 đã viết:
Tìm xem trong trong C:\Windows\SysWOW64 có file VBAVBA.dll chưa. Nếu chưa có thì copy thủ công vào. Sau đó thử chạy file này. Nhớ là phải Run as...
Nhấp chuột vào đây để mở rộng...
Chạy file Bat của anh xong vẫn thế, system32, SysWOW64 đều có file này, hjc. có đồ ăn ngon mà khó ăn thế, cứ làm tăng thêm độ thèm khát. Code cho 32bit và 64bit có khác nhau gì không anh Hải?

2015-02-01_101322.jpg
 
Upvote 0
NQ_AT đã viết:
Chạy file Bat của anh xong vẫn thế, system32, SysWOW64 đều có file này, hjc. có đồ ăn ngon mà khó ăn thế, cứ làm tăng thêm độ thèm khát. Code cho 32bit và 64bit có khác nhau gì không anh Hải?
Nhấp chuột vào đây để mở rộng...
Code của bác Quang Hải bị lỗi các công thức SUM (các ô tính tổng không còn đúng nữa).
Mình hướng dẫn cách làm như sau:
- Xóa 2 hàng cuối cùng đi, hàng gần cuối không có dữ liệu, hàng cuối là hàng tổng.
- Tại ô W11=LEFT(F11,2)="PW" kéo xuống
- Sort bảng với key là cột W để các giá trị TRUE xuống dưới (calculate automatic)
- Delete các dòng true, có thể autofilter cột W chọn true rồi xóa cả bảng.
- Sửa lại các công thức SUM và thêm dòng total cuối cùng.
Tất cả các bước đều có thể dùng VBA để xử lý, tiếc là mình lại không biết VBA.
 
Upvote 0
Hau151978 đã viết:
Code của bác Quang Hải bị lỗi các công thức SUM (các ô tính tổng không còn đúng nữa).
Mình hướng dẫn cách làm như sau:
- Xóa 2 hàng cuối cùng đi, hàng gần cuối không có dữ liệu, hàng cuối là hàng tổng.
- Tại ô W11=LEFT(F11,2)="PW" kéo xuống
- Sort bảng với key là cột W để các giá trị TRUE xuống dưới (calculate automatic)
- Delete các dòng true, có thể autofilter cột W chọn true rồi xóa cả bảng.
- Sửa lại các công thức SUM và thêm dòng total cuối cùng.
Tất cả các bước đều có thể dùng VBA để xử lý, tiếc là mình lại không biết VBA.
Nhấp chuột vào đây để mở rộng...
Anh Hậu mà không biết VBA thì ai biết bây giờ, khụ khụ
 
Upvote 0
ndu96081631 đã viết:
Lý do này hay nhỉ?
Mình nghĩ nếu bạn mà nghiên cứu VBA thì chưa chắc ai địch nỗi (dựa vào kiến thức của bạn)
Ẹc... Ẹc...
Nhấp chuột vào đây để mở rộng...

Tôi không chắc là mình hiểu ý bạn ấy.
Nhưng nếu câu này do tôi nói (không biết VBA) thì nó có nghĩa là:
Cái này muốn viết code thì tôi phải nghiên cứu. Mà nghiên cứu sói trán chỉ để dùng một vài lần thì không bõ công. Cho nên dùng tay cho khoẻ.
 
Upvote 0
Thường với dữ liệu lớn thì ít ai dùng định dạng nhiều, và hạn chế dùng công thức.
 
Upvote 0
Hau151978 đã viết:
Code của bác Quang Hải bị lỗi các công thức SUM (các ô tính tổng không còn đúng nữa).
Mình hướng dẫn cách làm như sau:
- Xóa 2 hàng cuối cùng đi, hàng gần cuối không có dữ liệu, hàng cuối là hàng tổng.
- Tại ô W11=LEFT(F11,2)="PW" kéo xuống
- Sort bảng với key là cột W để các giá trị TRUE xuống dưới (calculate automatic)
- Delete các dòng true, có thể autofilter cột W chọn true rồi xóa cả bảng.
- Sửa lại các công thức SUM và thêm dòng total cuối cùng.
Tất cả các bước đều có thể dùng VBA để xử lý, tiếc là mình lại không biết VBA.
Nhấp chuột vào đây để mở rộng...
Phần SUM đó nếu không sửa được thì em chạy lại bằng tay cũng được anh, Phần khó nhất với em bây giờ là bỏ dòng có PW* thật nhanh >>> Hay là SUM này mình chuyển luôn qua Code anh?
Có anh nào dùng Windows 64bit thì test giúp em được hay không nha.
Chắc em phải copy chạy ra tiệm net làm thử quá. Máy em chạy không được ức chế.
quanghai1969 đã viết:
Thường với dữ liệu lớn thì ít ai dùng định dạng nhiều, và hạn chế dùng công thức.
Nhấp chuột vào đây để mở rộng...
Tại em thấy dùng công thức thì nó linh hoạt, muốn thế nào cũng được. hjc.
 
Lần chỉnh sửa cuối:
Upvote 0
Như đã nói
giola đã viết:
........ bạn hãy quay lại chính bài #1 của bạn đó, đặt vấn đề lại là bạn cần gì (?) , hãy nghĩ khác xoá đi,
...
Nhấp chuột vào đây để mở rộng...

Từ code bài 1 thấy rằng mục đích chính của bạn là tạo file mới với dữ liệu lọc là không chứa các dòng mà tài cột F có giá trị PW*,

Nên hình thành code sau (bổ sung, nâng cấp code #1 của bạn thôi) - đảm bảo tốc độ nhanh chấp nhận được, kết quả có đầy đủ định dạng format gốc

Mã: 
Sub copyPppp()
    Dim t
    t = Timer
    
    Const sDK = "<>PW*"
    Dim Cll As Range
    Dim lR As Long
    Dim wbN As Workbook
    Dim rG As Range
    Dim Rg2 As Range
    Dim rgG As Range
    
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False:  .EnableEvents = False
        .Calculation = xlCalculationAutomatic
    End With
    
    With ActiveSheet       
        .AutoFilterMode = False
         lR = .Cells(65000, 3).End(xlUp).Row
        Set rgG = .Range("F8").Offset(, -5).Resize(, 22)
        With .Range("F8:F" & lR)
            .AutoFilter Field:=1, Criteria1:=sDK
            Set rG = .Offset(, -5).Resize(, 22).SpecialCells(xlCellTypeVisible)
        End With
    
        Set wbN = Workbooks.Add
        Set Rg2 = wbN.Sheets(1).Range("A8")
        
        rG.Copy
        Rg2.PasteSpecial xlPasteValues
        Rg2.PasteSpecial xlPasteFormats
        rgG.Copy
        Rg2.PasteSpecial xlPasteColumnWidths
        
        .AutoFilterMode = False
    End With
    With Application
        .CutCopyMode = False: .ScreenUpdating = True: .DisplayAlerts = True:   .EnableEvents = True
    End With
    t = Timer - t
    MsgBox "Thoi gian thuc hien chuong trinh:  " & t
End Sub

Chắc bạn biết VBA, và thạo Excel nên

- tự thêm lệnh xóa cột nào cần bỏ đi
- tự thêm lệnh save file
- và chú ý nên thay các công thức SUM thay SUBTOTAL(109, ....) với tham số hàm 109 để không tính tổng các giá trị ẩn đi =======> thì kết quả tổng mới đúng.
ví dụ M11 thành: =SUBTOTAL(109,M12:M38)+SUBTOTAL(109,M43:M45)

 
Lần chỉnh sửa cuối:
Upvote 0
NQ_AT đã viết:
Phần SUM đó nếu không sửa được thì em chạy lại bằng tay cũng được anh, Phần khó nhất với em bây giờ là bỏ dòng có PW* thật nhanh >>> Hay là SUM này mình chuyển luôn qua Code anh?
Có anh nào dùng Windows 64bit thì test giúp em được hay không nha.
Chắc em phải copy chạy ra tiệm net làm thử quá. Máy em chạy không được ức chế.

Tại em thấy dùng công thức thì nó linh hoạt, muốn thế nào cũng được. hjc.
Nhấp chuột vào đây để mở rộng...
Khi dữ liệu lớn thì việc xóa dòng sẽ rất chậm do excel phải di chuyển phần bảng từ dưới lên trên, nếu xóa dòng dưới cùng sẽ nhanh hơn vì không phải di chuyển. Vì vậy mình sort để các dòng cần xóa xuống dưới cùng rồi xóa 1 lần. Thêm cột công thức vào cột ngoài cùng bên phải chứ không insert cột cũng vì lý do trên. Chỉnh sửa công thức sum thì bạn chỉ cần dò những ô cột bên cạnh khác "" để tìm khoảng cần sum. Có thể record macro.
 
Upvote 0
To NQ_AT
cả hai trang đó điều nói rõ *.dll chỉ chạy trong Office 32....nếu là Win64+Office 64 thì không được mà phải cài win64+office32 thì chạy được file *.dll
nên sử dụng bản 32 thông dụng nhất tương thích với hầu hết các phần mềm bản 64 kén lắm
 
Upvote 0
kieu manh đã viết:
To NQ_AT
cả hai trang đó điều nói rõ *.dll chỉ chạy trong Office 32....nếu là Win64+Office 64 thì không được mà phải cài win64+office32 thì chạy được file *.dll
nên sử dụng bản 32 thông dụng nhất tương thích với hầu hết các phần mềm bản 64 kén lắm
Nhấp chuột vào đây để mở rộng...

Dạ, Hiện tại em đang tải bản 32bit, vì em thấy win 64 nên mới cài office 64 luôn. 64bit là mới mà nó không cho tương thích ngược nhỉ.)(&&@@
 
Upvote 0
giola đã viết:
Như đã nói


Từ code bài 1 thấy rằng mục đích chính của bạn là tạo file mới với dữ liệu lọc là không chứa các dòng mà tài cột F có giá trị PW*,

Nên hình thành code sau (bổ sung, nâng cấp code #1 của bạn thôi) - đảm bảo tốc độ nhanh chấp nhận được, kết quả có đầy đủ định dạng format gốc

Mã: 
Sub copyPppp()
    Dim t
    t = Timer
    
    Const sDK = "<>PW*"
    Dim Cll As Range
    Dim lR As Long
    Dim wbN As Workbook
    Dim rG As Range
    Dim Rg2 As Range
    Dim rgG As Range
    
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False:  .EnableEvents = False
        .Calculation = xlCalculationAutomatic
    End With
    
    With ActiveSheet       
        .AutoFilterMode = False
         lR = .Cells(65000, 3).End(xlUp).Row
        Set rgG = .Range("F8").Offset(, -5).Resize(, 22)
        With .Range("F8:F" & lR)
            .AutoFilter Field:=1, Criteria1:=sDK
            Set rG = .Offset(, -5).Resize(, 22).SpecialCells(xlCellTypeVisible)
        End With
    
        Set wbN = Workbooks.Add
        Set Rg2 = wbN.Sheets(1).Range("A8")
        
        rG.Copy
        Rg2.PasteSpecial xlPasteValues
        Rg2.PasteSpecial xlPasteFormats
        rgG.Copy
        Rg2.PasteSpecial xlPasteColumnWidths
        
        .AutoFilterMode = False
    End With
    With Application
        .CutCopyMode = False: .ScreenUpdating = True: .DisplayAlerts = True:   .EnableEvents = True
    End With
    t = Timer - t
    MsgBox "Thoi gian thuc hien chuong trinh:  " & t
End Sub

Chắc bạn biết VBA, và thạo Excel nên

- tự thêm lệnh xóa cột nào cần bỏ đi
- tự thêm lệnh save file
- và chú ý nên thay các công thức SUM thay SUBTOTAL(109, ....) với tham số hàm 109 để không tính tổng các giá trị ẩn đi =======> thì kết quả tổng mới đúng.
ví dụ M11 thành: =SUBTOTAL(109,M12:M38)+SUBTOTAL(109,M43:M45)

Nhấp chuột vào đây để mở rộng...
Cảm ơn anh rất nhiều, Code của anh chạy rất nhanh, Form vẫn giữ ok, nhưng anh khắc phục giúp 1 vài vấn đề sau:

- Trong file còn nhiều Sheet khác liên kết đến, do đó không thể Paste sang 1 workbook mới được, phải Paste lại trên sheet hiện hành nha anh.
- Chiều cao cột tăng thành 15, trong khi định dạng ban đầu có hàng 14.25, có hàng nhỏ hơn.
 
Upvote 0
NQ_AT đã viết:
Cảm ơn anh rất nhiều, Code của anh chạy rất nhanh, Form vẫn giữ ok, nhưng anh khắc phục giúp 1 vài vấn đề sau:

- Trong file còn nhiều Sheet khác liên kết đến, do đó không thể Paste sang 1 workbook mới được, phải Paste lại trên sheet hiện hành nha anh.
- Chiều cao cột tăng thành 15, trong khi định dạng ban đầu có hàng 14.25, có hàng nhỏ hơn.
Nhấp chuột vào đây để mở rộng...

Sao cột lại có chiều cao ??? chắc là dòng?

Bạn phức tạp nhỉ, muốn thế sử dụng cách củ chuối -code sau- vẫn khá nhanh
(chú ý khi thử chạy chương trình, nên copy 1 file lưu trước, vì không thể undo những dòng đã xoá đâu, các chú ý khác như thay SUM thành SUbtotal, xoá cột vẫn như bài trước... )

Mã: 
Sub copyPppp2()
    Dim t
    t = Timer
    
    Const sDK = "<>PW*"
    Dim Cll As Range
    Dim lR As Long
    Dim wbN As Workbook
    Dim rG As Range
    Dim Rg2 As Range
    Dim rgG As Range
    
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False:  .EnableEvents = False
        .Calculation = xlCalculationAutomatic
    End With
    
    With ActiveSheet
        lR = .Cells(65000, 3).End(xlUp).Row
        .AutoFilterMode = False
        Set rgG = .Range("F8:F" & lR)
        With rgG
            .AutoFilter Field:=1, Criteria1:=sDK
            Set rG = .Offset(, -5).Resize(, 22).SpecialCells(xlCellTypeVisible)
        End With
    
        If rG.Rows.Count = lR - 8 + 1 Then
            MsgBox "Khong co dong nao cot [F:F] =PW*"
            .AutoFilterMode = False
            GoTo end_
        End If
        Set wbN = Workbooks.Add
        Set Rg2 = wbN.Sheets(1).Range("A8")
        
        rG.Copy
        Rg2.PasteSpecial xlPasteValues
        Rg2.PasteSpecial xlPasteFormats
        Set Rg2 = Rg2.CurrentRegion '' .Resize(Rg2.Offset(65000, 2).End(xlUp).Row - Rg2.Row + 1, 22)
        .AutoFilterMode = False
        rgG.EntireRow.Delete
        Rg2.Copy .[A8]
        wbN.Close False
    End With

    t = Timer - t
    MsgBox "Thoi gian thuc hien chuong trinh:  " & t

end_:
    With Application
        .CutCopyMode = False: .ScreenUpdating = True: .DisplayAlerts = True:   .EnableEvents = True
    End With
End Sub
 
Upvote 0
Vì bạn sẽ save as sang file khác, nên code trên tốt nhất để vào 1 file trắng, đặt phím tắt (mở lên cùng khi cần chạy)

hoặc là cho vào addins

các cái này chắc bạn làm tốt
 
Upvote 0
giola đã viết:
Vì bạn sẽ save as sang file khác, nên code trên tốt nhất để vào 1 file trắng, đặt phím tắt (mở lên cùng khi cần chạy)

hoặc là cho vào addins

các cái này chắc bạn làm tốt
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh giola, Code của anh chạy rất ok.
Vì Save as ra file khác sau khi chạy code, nên em ko lo chuyện Back trở lại. Vì trước khi chạy em sẽ cho save workbook lại.
Còn chuyện add-in gì đó, e chưa biết tới. hjhjh. mới tập tành VBA mà.
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

L
Tính thời gian làm việc thực tế
Trả lời
66
Đọc
14K
YenTon
Y
H
Chia sẻ file in Phiếu điều tra PCGD
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
13
Đọc
627
Phuong7686
P
GPE-Trợ Lý
  • Dán lên cao
[KHẨN] HƯỚNG VỀ ĐỒNG BÀO CHỊU ẢNH HƯỞNG CỦA BÃO YAGI - BẢO YÊN, LÀO CAI
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
91
Đọc
14K
SA_DQ
SA_DQ
SA_DQ
Copilot bình luận về một ván cờ vua
    • Thích
Trả lời
6
Đọc
409
SA_DQ
SA_DQ
92nguyenthanh
  • Question Question
Vba cho file nhập xuất kho (1 người xem)
Trả lời
4
Đọc
107
HUONGHCKT
H
C
Fix lỗi Application.InputBox Type:=8
    • Cười
Trả lời
25
Đọc
618
ptm0412
ptm0412
GPE-Trợ Lý
[GPE] TALK SHOW 08: GIẢI QUYẾT VẤN ĐỀ TỐI ƯU HÓA TRONG EXCEL VỚI CÔNG CỤ SOLVER
    • Thích
    • Cảm ơn
Trả lời
4
Đọc
3K
DuongLeHung
D
Gà Công Nghệ
Chế độ chính sách cho giáo viên mầm non giữ trẻ khuyết tật (1 người xem)
Trả lời
1
Đọc
57
vanle33
vanle33
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
56
Đọc
22K
dunghtgiga
dunghtgiga
L
  • Question Question
Viết code tìm kiếm các file trong Folder (1 người xem)
Trả lời
40
Đọc
12K
lan nguyen0987
L
P
Hyperlink_Cách chuyển cả thư mục và file tổng hợp sang máy khác không bị lỗi
Trả lời
5
Đọc
108
phongvanvu
P
HeSanbi
Tiện ích Web: Tự động nhấn nút "Bỏ qua" quảng cáo Youtube
    • Thích
    • Yêu thích
Trả lời
14
Đọc
1K
ongke0711
ongke0711
ptm0412
Quá tin tưởng vào AI các thể loại
    • Cười
Trả lời
4
Đọc
218
Maika8008
Maika8008
A
  • Question Question
Không tìm được lỗi code
Trả lời
6
Đọc
159
ptm0412
ptm0412
W
Tham chiếu theo chuỗi ký tự
Trả lời
8
Đọc
314
dungpham01
D
tritv.dad
Lấy dữ liệu từ folder các tờ khai thông quan để theo dõi hiệu suất công việc.
Trả lời
8
Đọc
285
BlueSphere
B
GPE-Trợ Lý
MỪNG NGÀY NHÀ GIÁO VIỆT NAM 20/11 (1 người xem)
    • Thích
Trả lời
0
Đọc
2K
GPE-Trợ Lý
GPE-Trợ Lý
SA_DQ
Xin chúc mừng các thầy cô giáo trên cộng đồng nhân 20/11
    • Thích
    • Yêu thích
Trả lời
1
Đọc
135
BuiQuangThuan
B
M
chuyển đổi số thành chữ
Trả lời
15
Đọc
371
dungpham01
D
V
Lỗi copy sheet: the name already exists.
Trả lời
7
Đọc
702
nghiabros
N
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

Thời gian đếm ngược.

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