[Hỏi] Cách tạo code VBA tự xóa cột định sẵn trong Excel? (1 người xem)

[ultimatum86]

Xin chào các anh/chị,

Mình có 1 yêu cầu thế này, không biết có làm được không, nhờ anh/chị xem qua giúp nha.
Mình có 1 file Excel có chứa công thức Vlookup từ cột B > cột Z. Bây giờ mình tạo 1 button bên Sheet 2, khi nào nhấn button này thì toàn bộ dữ liệu bên sheet 1 từ cột B > cột X sẽ được Copy/ Paste Special ( không còn công thức gì nữa), sau đó các cột B, E, F, G, I sẽ được xóa đi, và có 1 bảng yêu cầu Save As hiện ra để người dùng lưu với tên khác ( cái này không có cũng được).
Mong anh chị xem giúp có thể giải quyết vấn đề này không?

 

[phucbugis]

Xin chào các anh/chị,

Mình có 1 yêu cầu thế này, không biết có làm được không, nhờ anh/chị xem qua giúp nha.
Mình có 1 file Excel có chứa công thức Vlookup từ cột B > cột Z. Bây giờ mình tạo 1 button bên Sheet 2, khi nào nhấn button này thì toàn bộ dữ liệu bên sheet 1 từ cột B > cột X sẽ được Copy/ Paste Special ( không còn công thức gì nữa), sau đó các cột B, E, F, G, I sẽ được xóa đi, và có 1 bảng yêu cầu Save As hiện ra để người dùng lưu với tên khác ( cái này không có cũng được).
Mong anh chị xem giúp có thể giải quyết vấn đề này không?

bạn có file ko ---> up lên đi, để mọi người còn thử code nữa (vừa tạo số liệu (từ cột B -> Z) + viết code ---> chắc chít )

 

[ultimatum86]

bạn có file ko ---> up lên đi, để mọi người còn thử code nữa (vừa tạo số liệu (từ cột B -> Z) + viết code ---> chắc chít )

Xin lỗi bữa giờ mình đi công tác nên hok phản hồi được.
Mình up file lên bạn xem giúp nha.
Khi mình bấm Button thì toàn bộ các cột từ A>L sẽ không còn công thức gì nữa ( dạng Copy paste special)
Cụ thể mình muốn xóa các cột sau: B, E, H, I, J , K.
Còn dòng thì những nó sẽ lọc cột F, dòng nào có chữ PW thì xóa hết.

Thanks Bạn rất nhiều.

 

[nghiaphuc]

Xin lỗi bữa giờ mình đi công tác nên hok phản hồi được.
Mình up file lên bạn xem giúp nha.
Khi mình bấm Button thì toàn bộ các cột từ A>L sẽ không còn công thức gì nữa ( dạng Copy paste special)
Cụ thể mình muốn xóa các cột sau: B, E, H, I, J , K.
Còn dòng thì những nó sẽ lọc cột F, dòng nào có chữ PW thì xóa hết.

Thanks Bạn rất nhiều.

Bạn dùng code sau xem sao:
[GPECODE=vb]Sub Test()
Dim Cll As Range, lR As Long
On Error Resume Next
Sheet3.Activate
lR = Cells.Find("*", , , , , xlPrevious).Row 'Xac dinh dong cuoi"
Range("A8:L" & lR).Value = Range("A8:L" & lR).Value 'Chuyen thanh gia tri'
[B:B,E:E,H:K].Delete 'Xoa cac cot theo yeu cau'
Do
Set Cll = Range("D8" & lR).Find("PW", , xlValues, xlWhole) 'Tim dong co gia tri PW'
If Not Cll Is Nothing Then Cll.EntireRow.Delete 'Xoa dong tim duoc'
Loop Until Cll Is Nothing
End Sub[/GPECODE]

 

[ultimatum86]

Bạn dùng code sau xem sao:
[GPECODE=vb]Sub Test()
Dim Cll As Range, lR As Long
On Error Resume Next
Sheet3.Activate
lR = Cells.Find("*", , , , , xlPrevious).Row 'Xac dinh dong cuoi"
Range("A8:L" & lR).Value = Range("A8:L" & lR).Value 'Chuyen thanh gia tri'
[B:B,E:E,H:K].Delete 'Xoa cac cot theo yeu cau'
Do
Set Cll = Range("D8" & lR).Find("PW", , xlValues, xlWhole) 'Tim dong co gia tri PW'
If Not Cll Is Nothing Then Cll.EntireRow.Delete 'Xoa dong tim duoc'
Loop Until Cll Is Nothing
End Sub[/GPECODE]

Ok, Mình sẽ làm thử, nhưng button này nằm bên sheet khác nha bạn.
Mình rất thích chữ ký của bạn.
Thanks.

Do mình đặt Button nằm ở Sheet khác nên mình có sửa lại thế này, bạn xem ok hok nha.

Sub Test()    Dim Cll As Range, lR As Long
    On Error Resume Next
    With Sheets("SCOPE OF WORK")
    lR = Cells.Find("*", , , , , xlPrevious).Row 'Xac dinh dong cuoi"
    Range("A8:L" & lR).Value = Range("A8:L" & lR).Value 'Chuyen thanh gia tri'
    [B:B,E:E,H:K].Delete 'Xoa cac cot theo yeu cau'
    Do
        Set Cll = Range("D8:D" & lR).Find("PW", , xlValues, xlWhole) 'Tim dong co gia tri PW'
        If Not Cll Is Nothing Then Cll.EntireRow.Delete 'Xoa dong tim duoc'
    Loop Until Cll Is Nothing
    End With
End Sub

còn 1 điều nữa là Button này chỉ thực hiện lệnh 1 lần thôi, vô tình bấm nhiều lần nó xóa tè le hết. và sau khi nó xóa xong sẽ hiện ra 1 bản Save As để lưu với tên khác ( xóa xong mà lưu đè lên thì cắn lưỡi).
Vậy mình phải thêm như thế nào đây bạn?

 

[nghiaphuc]

Ok, Mình sẽ làm thử, nhưng button này nằm bên sheet khác nha bạn.
Mình rất thích chữ ký của bạn.
Thanks.

Do mình đặt Button nằm ở Sheet khác nên mình có sửa lại thế này, bạn xem ok hok nha.

Sub Test()    Dim Cll As Range, lR As Long
    On Error Resume Next
    With Sheets("SCOPE OF WORK")
    lR = Cells.Find("*", , , , , xlPrevious).Row 'Xac dinh dong cuoi"
    Range("A8:L" & lR).Value = Range("A8:L" & lR).Value 'Chuyen thanh gia tri'
    [B:B,E:E,H:K].Delete 'Xoa cac cot theo yeu cau'
    Do
        Set Cll = Range("D8:D" & lR).Find("PW", , xlValues, xlWhole) 'Tim dong co gia tri PW'
        If Not Cll Is Nothing Then Cll.EntireRow.Delete 'Xoa dong tim duoc'
    Loop Until Cll Is Nothing
    End With
End Sub

còn 1 điều nữa là Button này chỉ thực hiện lệnh 1 lần thôi, vô tình bấm nhiều lần nó xóa tè le hết. và sau khi nó xóa xong sẽ hiện ra 1 bản Save As để lưu với tên khác ( xóa xong mà lưu đè lên thì cắn lưỡi).
Vậy mình phải thêm như thế nào đây bạn?

Bạn nghĩ đến câu lệnh With là hợp lý rồi, tuy nhiên code lại sai, hãy nhớ rằng sau câu lệnh With thì những gì thuộc về đối tượng sau từ khóa With (cụ thể là thuộc về Sheets("SCOPE OF WORK")) phải được đặt sau dấu chấm, nếu không thì VBA sẽ hiểu các đối tượng này thuộc về sheet hiện hành.

Code sau khi sửa sẽ như sau:
[GPECODE=vb]Sub Test()
Dim Cll As Range, lR As Long
On Error Resume Next
ThisWorkbook.Save 'Luu lai file truoc khi chay code, co the bo di neu khong can thiet'
With Sheets("SCOPE OF WORK")
lR = .Cells.Find("*", , , , , xlPrevious).Row 'Xac dinh dong cuoi'
.Range("A8:L" & lR).Value = .Range("A8:L" & lR).Value 'Chuyen thanh gia tri'
.[B:B,E:E,H:K].Delete 'Xoa cac cot theo yeu cau'
Do
Set Cll = .Range("D8" & lR).Find("PW", , xlValues, xlWhole) 'Tim dong co gia tri PW'
If Not Cll Is Nothing Then Cll.EntireRow.Delete 'Xoa dong tim duoc'
Loop Until Cll Is Nothing
End With
Application.DisplayAlerts = False
ThisWorkbook.SaveAs Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 1) & "x", 51 'Luu mot ban sao khong chua Macro'
Application.DisplayAlerts = True
End Sub[/GPECODE]
Trong code trên, dòng lệnh thứ 4 nhằm mục đích lưu lại những thay đổi trên file hiện hành (lưu trạng thái trước khi chạy code), nếu bạn đã chủ động lưu thủ công trước đó thì có thể bỏ qua dòng lệnh này. Còn dòng lệnh thứ 15 nhằm mục đích lưu file sau khi chạy code thành 1 bản sao không chứa macro, vậy là file ban đầu không bị ảnh hưởng. Câu lệnh thứ 14 chỉ là để "làm biếng" nhấn hộp thoại cảnh báo khi lưu file qua định dạng .xlsx thôi.

Rất cảm ơn bạn vì lời khen!

 

[ultimatum86]

Bạn nghĩ đến câu lệnh With là hợp lý rồi, tuy nhiên code lại sai, hãy nhớ rằng sau câu lệnh With thì những gì thuộc về đối tượng sau từ khóa With (cụ thể là thuộc về Sheets("SCOPE OF WORK")) phải được đặt sau dấu chấm, nếu không thì VBA sẽ hiểu các đối tượng này thuộc về sheet hiện hành.

Code sau khi sửa sẽ như sau:
[GPECODE=vb]Sub Test()
Dim Cll As Range, lR As Long
On Error Resume Next
ThisWorkbook.Save 'Luu lai file truoc khi chay code, co the bo di neu khong can thiet'
With Sheets("SCOPE OF WORK")
lR = .Cells.Find("*", , , , , xlPrevious).Row 'Xac dinh dong cuoi'
.Range("A8:L" & lR).Value = .Range("A8:L" & lR).Value 'Chuyen thanh gia tri'
.[B:B,E:E,H:K].Delete 'Xoa cac cot theo yeu cau'
Do
Set Cll = .Range("D8" & lR).Find("PW", , xlValues, xlWhole) 'Tim dong co gia tri PW'
If Not Cll Is Nothing Then Cll.EntireRow.Delete 'Xoa dong tim duoc'
Loop Until Cll Is Nothing
End With
Application.DisplayAlerts = False
ThisWorkbook.SaveAs Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 1) & "x", 51 'Luu mot ban sao khong chua Macro'
Application.DisplayAlerts = True
End Sub[/GPECODE]
Trong code trên, dòng lệnh thứ 4 nhằm mục đích lưu lại những thay đổi trên file hiện hành (lưu trạng thái trước khi chạy code), nếu bạn đã chủ động lưu thủ công trước đó thì có thể bỏ qua dòng lệnh này. Còn dòng lệnh thứ 15 nhằm mục đích lưu file sau khi chạy code thành 1 bản sao không chứa macro, vậy là file ban đầu không bị ảnh hưởng. Câu lệnh thứ 14 chỉ là để "làm biếng" nhấn hộp thoại cảnh báo khi lưu file qua định dạng .xlsx thôi.

Rất cảm ơn bạn vì lời khen!

Hic. đã tìm đúng thầy, đúng thuốc, còn hướng dẫn rõ ràng nữa. Cảm ơn bạn rất nhiều.

Vì mình muốn xóa luôn cả Sheet chứa Button nên mình có thêm 1 câu lệnh.
[GPECODE=vb]Sub Test()
Dim Cll As Range, lR As Long
On Error Resume Next
ThisWorkbook.Save 'Luu lai file truoc khi chay code, co the bo di neu khong can thiet'
With Sheets("SCOPE OF WORK")
lR = .Cells.Find("*", , , , , xlPrevious).Row 'Xac dinh dong cuoi'
.Range("A8:L" & lR).Value = .Range("A8:L" & lR).Value 'Chuyen thanh gia tri'
.[B:B,E:E,H:K].Delete 'Xoa cac cot theo yeu cau'
Do
Set Cll = .Range("D8" & lR).Find("PW", , xlValues, xlWhole) 'Tim dong co gia tri PW'
If Not Cll Is Nothing Then Cll.EntireRow.Delete 'Xoa dong tim duoc'
Loop Until Cll Is Nothing
End With
Application.DisplayAlerts = False
Sheet1.Delete 'Chỉ biết nhập Sheet thôi, còn muốn nhập tên Sheet thì không biết nhập thế nào? hjhj[/COLOR]
ThisWorkbook.SaveAs Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 5) & "-To Customer.xlsx", 51 'Luu mot ban sao khong chua Macro'
Application.DisplayAlerts = True
End Sub[/GPECODE]

 

[ultimatum86]

Hj Bạn Phúc,

Sau khi mình đưa vào Form thật sự thì từ 1000 dòng trở lên nó chạy rất chậm,

Bạn xem lại giúp có cách nào chạy nhanh trong trường hợp này ko nha.

Thanks bạn.

 

[nghiaphuc]

Hj Bạn Phúc,

Sau khi mình đưa vào Form thật sự thì từ 1000 dòng trở lên nó chạy rất chậm,

Bạn xem lại giúp có cách nào chạy nhanh trong trường hợp này ko nha.

Thanks bạn.

Vậy thì thay vì vòng lặp Do-While kia để tìm và xóa lần lượt từng dòng có chứa PW, bạn sử dụng AutoFilter để lọc ra các dòng có chứa PW, sau đó xóa kết quả lọc (có sử dụng đến SpecialCells(12) để lấy những dòng hiển thị, tức là kết quả lọc). Bạn thử đi, không khó đâu. Tôi nghĩ rằng cách này sẽ tăng tốc đáng kể vì chỉ lọc và xóa một lần.

 

[ultimatum86]

Vậy thì thay vì vòng lặp Do-While kia để tìm và xóa lần lượt từng dòng có chứa PW, bạn sử dụng AutoFilter để lọc ra các dòng có chứa PW, sau đó xóa kết quả lọc (có sử dụng đến SpecialCells(12) để lấy những dòng hiển thị, tức là kết quả lọc). Bạn thử đi, không khó đâu. Tôi nghĩ rằng cách này sẽ tăng tốc đáng kể vì chỉ lọc và xóa một lần.

Mong Bạn sửa giúp lại code, vì mình chưa biết viết code này, chỉ biết đọc hiểu thôi, hhjh

 

[nghiaphuc]

Mong Bạn sửa giúp lại code, vì mình chưa biết viết code này, chỉ biết đọc hiểu thôi, hhjh

Vậy thì lại làm cho bạn vậy:
[GPECODE=vb]Sub Test()
Dim Cll As Range, lR As Long
With Application
.ScreenUpdating = False: .DisplayAlerts = False: .Calculation = xlCalculationManual
End With
On Error Resume Next
ThisWorkbook.Save
With Sheets("SCOPE OF WORK")
lR = .Cells.Find("*", , , , , xlPrevious).Row 'Xac dinh dong cuoi'
.Range("A8:L" & lR).Value = .Range("A8:L" & lR).Value 'Chuyen thanh gia tri'
.[B:B,E:E,H:K].Delete 'Xoa cac cot theo yeu cau'
.Range("D8" & lR).AutoFilter 1, "PW" 'Loc cac dong co gia tri PW
.Range("D9" & lR).SpecialCells(12).EntireRow.Delete 'Xoa ket qua loc
.Range("D8" & lR).AutoFilter 'Tat che do loc
End With
Sheets("Sheet1").Delete
ThisWorkbook.SaveAs Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 5) & " - To Customer.xlsx", 51 'Luu mot ban sao khong chua Macro'
With Application
.ScreenUpdating = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic
End With
End Sub[/GPECODE]

 

[ultimatum86]

Vậy thì lại làm cho bạn vậy:
[GPECODE=vb]Sub Test()
Dim Cll As Range, lR As Long
With Application
.ScreenUpdating = False: .DisplayAlerts = False: .Calculation = xlCalculationManual
End With
On Error Resume Next
ThisWorkbook.Save
With Sheets("SCOPE OF WORK")
lR = .Cells.Find("*", , , , , xlPrevious).Row 'Xac dinh dong cuoi'
.Range("A8:L" & lR).Value = .Range("A8:L" & lR).Value 'Chuyen thanh gia tri'
.[B:B,E:E,H:K].Delete 'Xoa cac cot theo yeu cau'
.Range("D8" & lR).AutoFilter 1, "PW" 'Loc cac dong co gia tri PW
.Range("D9" & lR).SpecialCells(12).EntireRow.Delete 'Xoa ket qua loc
.Range("D8" & lR).AutoFilter 'Tat che do loc
End With
Sheets("Sheet1").Delete
ThisWorkbook.SaveAs Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 5) & " - To Customer.xlsx", 51 'Luu mot ban sao khong chua Macro'
With Application
.ScreenUpdating = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic
End With
End Sub[/GPECODE]

Đã test, cột thì xóa ok, nhưng dòng thì nó vẫn y nguyên ko xóa dòng nào cả bạn ah.

Mình copy code này bỏ vào Sheet " Scope of Work" còn button thì để bên Sheet 1. Vậy có không bạn? hay là bỏ code vào Module?

 

[nghiaphuc]

Đã test, cột thì xóa ok, nhưng dòng thì nó vẫn y nguyên ko xóa dòng nào cả bạn ah.

Mình copy code này bỏ vào Sheet " Scope of Work" còn button thì để bên Sheet 1. Vậy có không bạn? hay là bỏ code vào Module?

Code để trong Module, còn cái Button kia thì Assign Macro đến Sub này.
Bạn tham khảo trong file đính kèm nhé.

 

[ultimatum86]

Code để trong Module, còn cái Button kia thì Assign Macro đến Sub này.
Bạn tham khảo trong file đính kèm nhé.

Không hiểu sao, trên file Test thì chạy ok, mà copy qua file của mình thì nó ko xóa được dòng, 2 file như nhau thôi. Để ktra 1 lần nữa xem sao.

Thanks Bạn Phúc nhiều nha,

Ah, cho mình hỏi thêm chút:
- mình vẫn muốn file gốc vẫn mở sau khi Save As được không?
- file mình chủ yếu dùng Vlookup nên khi làm nhiều dòng nặng lắm, bạn có cao kiến gì giúp mình vấn đề này không?

>>>>>Tìm ra nguyên nhân <<<<
Khi mình ko cho nó chạy lệnh " tắt chế độ Filter" thì vào lại file thấy nó đang filter cột A. Do đó nó không thể xóa các dòng có chữ PW

Sao nó lại chạy về Filter cột A vậy Phúc?

 

[ultimatum86]

Mình đã tìm được nguyên nhân, do trong form của mình có sẵn chế độ Filter nên nó không chạy được, mình phải điều chỉnh code để nó bỏ Filter trước.
Thanks bạn Phúc nhiều nha.