Em chào các anh chị!
Có code nào có thể test 1 điều kiện nào đó để xóa toàn bộ vba trong file Excel được không ạ?
Cụ thể là
ô A1! của sheet 1! em đặt điều kiện hoặc =0 hoặc =1.
Khi Open file:
ô a1=1 thì file chạy bình thường.
Nếu A1=0 thì toàn bộ vba trong file bị xóa sạch.
Có được không ạ?
Sub Mcorrel(inprng As Variant, Optional outrng As Variant, Optional grouped As Variant, Optional labels As Variant)
xMcorrel = Application.Run(GetMacroRegId("fnMCorrel"), inprng, outrng, grouped, labels)
End Sub
Sub McorrelQ(Optional inprng As Variant, Optional outrng As Variant, Optional grouped As Variant, Optional labels As Variant)
xMcorrelQ = Application.Run(GetMacroRegId("fnMCorrelQ"), inprng, outrng, grouped, labels)
End Sub
Sub Mcovar(inprng As Variant, Optional outrng As Variant, Optional grouped As Variant, Optional labels As Variant)
xMcovar = Application.Run(GetMacroRegId("fnMCovar"), inprng, outrng, grouped, labels)
End Sub
Sub McovarQ(Optional inprng As Variant, Optional outrng As Variant, Optional grouped As Variant, Optional labels As Variant)
xMcovarQ = Application.Run(GetMacroRegId("fnMCovarQ"), inprng, outrng, grouped, labels)
End Sub
Sub Moveavg(inprng As Variant, Optional outrng As Variant, Optional interval As Variant, Optional stderrs As Variant, Optional chart As Variant, Optional labels As Variant)
xMoveavg = Application.Run(GetMacroRegId("fnMoveAvg"), inprng, outrng, interval, stderrs, chart, labels)
End Sub
Sub MoveavgQ(Optional inprng As Variant, Optional outrng As Variant, Optional interval As Variant, Optional stderrs As Variant, Optional chart As Variant, Optional labels As Variant)
xMoveavgQ = Application.Run(GetMacroRegId("fnMoveAvgQ"), inprng, outrng, interval, stderrs, chart, labels)
End Sub
Sub Pttestm(inprng1 As Variant, inprng2 As Variant, Optional outrng As Variant, Optional labels As Variant, Optional alpha As Variant, Optional difference As Variant)
xPttestm = Application.Run(GetMacroRegId("fnTtestM"), inprng1, inprng2, outrng, labels, alpha, difference)
End Sub
Sub PttestmQ(Optional inprng1 As Variant, Optional inprng2 As Variant, Optional outrng As Variant, Optional labels As Variant, Optional alpha As Variant, Optional difference As Variant)
xPttestmQ = Application.Run(GetMacroRegId("fnTtestMQ"), inprng1, inprng2, outrng, labels, alpha, difference)
End Sub
Sub Pttestv(inprng1 As Variant, inprng2 As Variant, Optional outrng As Variant, Optional labels As Variant, Optional alpha As Variant, Optional difference As Variant)
xPttestv = Application.Run(GetMacroRegId("fnTtestUeq"), inprng1, inprng2, outrng, labels, alpha, difference)
End Sub
Sub PttestvQ(Optional inprng1 As Variant, Optional inprng2 As Variant, Optional outrng As Variant, Optional labels As Variant, Optional alpha As Variant, Optional difference As Variant)
xPttestvQ = Application.Run(GetMacroRegId("fnTtestUeqQ"), inprng1, inprng2, outrng, labels, alpha, difference)
End Sub
Sub Ttestm(inprng1 As Variant, inprng2 As Variant, Optional outrng As Variant, Optional labels As Variant, Optional alpha As Variant, Optional difference As Variant)
xTtestm = Application.Run(GetMacroRegId("fnTtestEq"), inprng1, inprng2, outrng, labels, alpha, difference)
End Sub
Sub TtestmQ(Optional inprng1 As Variant, Optional inprng2 As Variant, Optional outrng As Variant, Optional labels As Variant, Optional alpha As Variant, Optional difference As Variant)
xTtestmQ = Application.Run(GetMacroRegId("fnTtestEqQ"), inprng1, inprng2, outrng, labels, alpha, difference)
End Sub
Sub zTestm(inprng1 As Variant, inprng2 As Variant, Optional outrng As Variant, Optional labels As Variant, Optional alpha As Variant, Optional difference As Variant, Optional var1 As Variant, Optional var2 As Variant)
xzTestm = Application.Run(GetMacroRegId("fnZtestM"), inprng1, inprng2, outrng, labels, alpha, difference, var1, var2)
End Sub
Sub zTestmQ(Optional inprng1 As Variant, Optional inprng2 As Variant, Optional outrng As Variant, Optional labels As Variant, Optional alpha As Variant, Optional difference As Variant, Optional var1 As Variant, Optional var2 As Variant)
xzTestmQ = Application.Run(GetMacroRegId("fnZtestMQ"), inprng1, inprng2, outrng, labels, alpha, difference, var1, var2)
End Sub
Sub Random(Optional outrng As Variant, Optional variables As Variant, Optional points As Variant, Optional distribution As Variant, Optional seed As Variant, Optional randarg1 As Variant, Optional randarg2 As Variant, Optional randarg3 As Variant, Optional randarg4 As Variant, Optional randarg5 As Variant)
xRandom = Application.Run(GetMacroRegId("fnRandom"), outrng, variables, points, distribution, seed, randarg1, randarg2, randarg3, randarg4, randarg5)
End Sub
Sub RandomQ(Optional outrng As Variant, Optional variables As Variant, Optional points As Variant, Optional distribution As Variant, Optional seed As Variant, Optional randarg1 As Variant, Optional randarg2 As Variant, Optional randarg3 As Variant, Optional randarg4 As Variant, Optional randarg5 As Variant)
xRandomQ = Application.Run(GetMacroRegId("fnRandomQ"), outrng, variables, points, distribution, seed, randarg1, randarg2, randarg3, randarg4, randarg5)
End Sub
Sub RankPerc(inprng As Variant, Optional outrng As Variant, Optional grouped As Variant, Optional labels As Variant)
xRankPerc = Application.Run(GetMacroRegId("fnRankPerc"), inprng, outrng, grouped, labels)
End Sub
Sub RankPercQ(Optional inprng As Variant, Optional outrng As Variant, Optional grouped As Variant, Optional labels As Variant)
xRankPercQ = Application.Run(GetMacroRegId("fnRankPercQ"), inprng, outrng, grouped, labels)
End Sub
Sub Regress(inpyrng As Variant, Optional inpxrng As Variant, Optional constant As Variant, Optional labels As Variant, Optional confid As Variant, Optional soutrng As Variant, Optional residuals As Variant, Optional sresiduals As Variant, Optional rplots As Variant, Optional lplots As Variant, Optional routrng As Variant, Optional nplots As Variant, Optional poutrng As Variant)
xRegress = Application.Run(GetMacroRegId("fnRegress"), inpyrng, inpxrng, constant, labels, confid, soutrng, residuals, sresiduals, rplots, lplots, routrng, nplots, poutrng)
End Sub
Sub RegressQ(Optional inpyrng As Variant, Optional inpxrng As Variant, Optional constant As Variant, Optional labels As Variant, Optional confid As Variant, Optional soutrng As Variant, Optional residuals As Variant, Optional sresiduals As Variant, Optional rplots As Variant, Optional lplots As Variant, Optional routrng As Variant, Optional nplots As Variant, Optional poutrng As Variant)
xRegressQ = Application.Run(GetMacroRegId("fnRegressQ"), inpyrng, inpxrng, constant, labels, confid, soutrng, residuals, sresiduals, rplots, lplots, routrng, nplots, poutrng)
End Sub
Sub Sample(inprng As Variant, Optional outrng As Variant, Optional method As Variant, Optional rate As Variant, Optional labels As Variant)
xSample = Application.Run(GetMacroRegId("fnSample"), inprng, outrng, method, rate, labels)
End Sub
Sub SampleQ(Optional inprng As Variant, Optional outrng As Variant, Optional method As Variant, Optional rate As Variant, Optional labels As Variant)
xSampleQ = Application.Run(GetMacroRegId("fnSampleQ"), inprng, outrng, method, rate, labels)
End Sub
Chân Tình mà nói có lẽ Thầy siwtom nên Remove cái file đính kèm hàng "ĐỘC" đó đi ạ!
Hihi! Đó là nỗi kinh hoàng của biết bao những người có Tâm Huyết cố gắng xây dựng và tìm cách bảo vệ những thứ có ích với mục đích tốt đẹp.
Đọc "bài đó" của Thầy chẳng ai mà chống đỡ được nữa ...@@!
Mình không hiểu bạn nói gì và ám chỉ bài của ai trong chủ đề này cả.
Mặt khác Chân Tình mà nói có lẽ Thầy siwtom nên Remove cái file đính kèm hàng ĐỘC đó đi ạ!
Hihi!
Thực tế mà nói mình không chuyên sâu gì bên mảng excel nhưng những bài như thế này có dính dáng tớ 1 phần công việc mình làm. Tùy bạn hay người khác nghĩ gì với mình tất cả rồi cũng chỉ là phù du mà thôi!
Mình không hiểu bạn nói gì và ám chỉ bài của ai trong chủ đề này cả. Mặt khác Chân Tình mà nói có lẽ Thầy siwtom nên Remove cái file đính kèm hàng ĐỘC đó đi ạ!
Hihi!
Đồng ý với bạn về câu tô đậm! ĐỘC ở đây tôi nghĩ là ĐỘC ĐÁO, nhưng nó có tính chất "xâm hại" đến code người khác nếu ai đó có ý phá hoại! Tôi cũng nghĩ Anh siwtom nên remove file đó đi thì hơn.
Đồng ý với bạn về câu tô đậm! ĐỘC ở đây tôi nghĩ là ĐỘC ĐÁO, nhưng nó có tính chất "xâm hại" đến code người khác nếu ai đó có ý phá hoại! Tôi cũng nghĩ Anh siwtom nên remove file đó đi thì hơn.
Hix! Em xem cũng chẳng hiểu gì cả những đọc thấy mấy bài của các Thầy nói lên sự bất ngờ qua bài viết của Thầy siwtom và nỗi lo sợ của mọi người đã cố công tạo nên nhưng thứ có ích mà bị kẻ xấu phá hoại. Tốt nhất nếu bỏ được thì bỏ đi Thầy à cho lành.
Đó cũng kiểu như là "Vi phạm bản quyền" hay còn gọi là xâm phạm trí tuệ...
Phạt 500.000.000 đồng đến 1.000.000.000 đòng nhưu chơi ý.... =)).
Mình thì chả thấy gì ghê gớm đến nỗi như 1 vài bạn đề nghị. Kiến thức thì phải có tính kế thừa. Nếu ai cũng giấu kín hết thì diễn đàn này sẽ đi về đâu.
Mình thì chả thấy gì ghê gớm đến nỗi như 1 vài bạn đề nghị. Kiến thức thì phải có tính kế thừa. Nếu ai cũng giấu kín hết thì diễn đàn này sẽ đi về đâu.
Thầy ơi Người Kế thừa luôn chỉ có một, Nhưng người lăm le để được thừa kế thì nhiều gấp bội và họ sẽ tìm đủ mọi cách bắt luận xấu hay đẹp hay là trời sập đi chăng nữa họ cũng chẳng sợ, Kết cục Những người muốn kế thừa này cũng chẳng Kế thừa được.
cũng phải do Duyên số nữa đó...
A!Hình như cả cái file của Thầy nữa thì phải ...hihihi.... Thầy là người "Châm Ngòi" phạt cũng như Thầy siwtom (1 tỷ đấy)!
Mình thì chả thấy gì ghê gớm đến nỗi như 1 vài bạn đề nghị. Kiến thức thì phải có tính kế thừa. Nếu ai cũng giấu kín hết thì diễn đàn này sẽ đi về đâu.
Đúng là kiến thức thì được dạy, được học có trường lớp, còn không thì cũng nên ít phổ biến những vấn đề "nhạy cảm" đi. Giống như cô gái chưa chồng vậy, ai nhìn trộm lúc cô ấy tắm là bị "độp" liền, tuy nhiên sẳn sàng cho người yêu mình ôm hôn, âu yếm. Nếu ai đó "cho", "tặng" "biếu" một cái kính có thể nhìn xuyên quần áo cô ấy và tất cả phụ nữ trên đời này, thì quả là hết sức ẹc ẹc ...
Thường người ta nói "khóa kẻ ngay", nhưng "con ong cũng bay qua, con kiến cũng lọt vào" quá dễ dàng thì "tội lắm thay".
Lúc đầu tôi cũng có nghĩ không vấn đề gì, nhưng giờ thấy nó quá độc đáo làm mình cảm thấy giật cả mình!
Nói như mọi người thì chẳng có diễn đàn nào có thể tồn tại lâu dài. Chúng ta biết chia sẽ rồi từ đó phát huy thôi. Nếu xét trên 1 quan điểm nào đó thì thật sự cái gì cũng sai cả và dĩ nhiên chẳng có cái gì đúng. Cía ta cần tìm ở đây là ứng dụng của nó là cấu trúc chuỗi của nó. Nhiều người sẽ cho rằng khi viết ra 1 đoạn mã nào đó hay chia sẽ 1 đoạn mã "không hay" thì sẽ tạo ra mặt trái của nó nhưng cái gì cũng có 2 mặt thôi. Chia sẽ không có nghĩa là giúp người khác phá hoại hay đánh cắp bất kỳ cái gì mà cái ở đây là tìm ra cách để ngăn chặn nó. Tôi rất ủng hộ ý kiến của mấy bạn nhưng có lẽ các bạn đang suy nghĩ vượt qua giới hạn của đoạn code viết ở trên rồi. Thân
Mình nói ngoài lề tí nha: Sau khi dùng code củasiwtom và unlock toàn bộ các Add-Ins của Microsoft... mọi người đã nhìn thấy code rồi, vậy có "chôm" được gì của bác Bill không (tức là học được gì ấy) hay chỉ là "nhìn" rồi... tối thui, chẳng biết ông Bill viết code quỷ gì cả?
Ẹc... Ẹc...
Sub DeleteProcedureCode(ByVal wb As Workbook, _
ByVal DeleteFromModuleName As String, ByVal ProcedureName As String)
' cần có tham chiếu Microsoft Visual Basic Extensibility library
' xóa ProcedureName khỏi DeleteFromModuleName trong bảng tính wb
'vd. DeleteProcedureCode Workbooks("vbe.xls"), "module2", "tinh toan"
Dim VBCM As CodeModule, ProcStartLine As Long, ProcLineCount As Long
On Error Resume Next
' module có phương thức cần xóa
Set VBCM = wb.VBProject.VBComponents(DeleteFromModuleName).CodeModule
If Not VBCM Is Nothing Then
' tìm dòng đầu của phương thức (kể cả các dòng ghi chú ở trước Function, Sub ProcedureName)
' nếu trả về 0 thì có nghĩa là phương thức không tồn tại
ProcStartLine = VBCM.ProcStartLine(ProcedureName, vbext_pk_Proc)
If ProcStartLine > 0 Then
' tổng số dòng của phương thức
ProcLineCount = VBCM.ProcCountLines(ProcedureName, vbext_pk_Proc)
' xóa tất cả các dòng của phương thức
VBCM.DeleteLines ProcStartLine, ProcLineCount
End If
Set VBCM = Nothing
End If
On Error GoTo 0
End Sub
Sub DeleteProcedureCode(ByVal wb As Workbook, _
ByVal DeleteFromModuleName As String, ByVal ProcedureName As String)
' cần có tham chiếu Microsoft Visual Basic Extensibility library
' xóa ProcedureName khỏi DeleteFromModuleName trong bảng tính wb
'vd. DeleteProcedureCode Workbooks("vbe.xls"), "module2", "tinh toan"
Dim VBCM As CodeModule, ProcStartLine As Long, ProcLineCount As Long
On Error Resume Next
' module có phương thức cần xóa
Set VBCM = wb.VBProject.VBComponents(DeleteFromModuleName).CodeModule
If Not VBCM Is Nothing Then
' tìm dòng đầu của phương thức (kể cả các dòng ghi chú ở trước Function, Sub ProcedureName)
' nếu trả về 0 thì có nghĩa là phương thức không tồn tại
ProcStartLine = VBCM.ProcStartLine(ProcedureName, vbext_pk_Proc)
If ProcStartLine > 0 Then
' tổng số dòng của phương thức
ProcLineCount = VBCM.ProcCountLines(ProcedureName, vbext_pk_Proc)
' xóa tất cả các dòng của phương thức
VBCM.DeleteLines ProcStartLine, ProcLineCount
End If
Set VBCM = Nothing
End If
On Error GoTo 0
End Sub
Thật là rõ khổ. Thì bạn cứ copy code về chạy thử coi thế nào.
Khuyến mãi cho bạn thêm code này
Sub này cần phải có check trong mục Trust access to the VBA project object
Mã:
Sub Xoa_Code()
Dim x As Integer
On Error Resume Next
With ActiveWorkbook.VBProject
For x = .VBComponents.Count To 1 Step -1
.VBComponents(x).CodeModule.DeleteLines 1, _
.VBComponents(x).CodeModule.CountOfLines
.VBComponents.Remove .VBComponents(x)
Next x
End With
End Sub
Code là tổng quát mà.
Bạn định xóa code của một hàm, phương thức nào đó? Rõ ràng nó phải có tên, đúng không? Thì nhập tên đó vào chỗ ProcedureName, tức thay cho "tinh toan" thì nhập vd. "MySecretFunction", với "MySecretFunction" là tên của hàm, phương thức cần xóa. Hơn thế nữa "MySecretFunction" nằm trong một module nào đó, đúng không? Giả dụ nằm trong "MySecretModule" thì thay vì "module2" thì nhập "MySecretModule" vào chỗ DeleteFromModuleName. Tất nhiên cái "MySecretModule" nó có trong workbook nào đó, đúng không? Thì nhập workbook đó vào chỗ wb thay cho Workbooks("vbe.xls"). Tức có thể nhập: Workbooks("MySecretBook.xls"), Workbooks(Book1.xls), Workbooks(1) v...v
Ví dụ là ví dụ về cách gọi. Khi bạn gọi phương thức thì bạn phải truyền thông số cụ thể cho lần gọi ấy chứ.
Có điều chắc chắn là ta không thể nhớ chính xác tên đối tượng cần xóa. Vậy cần thêm 1 thủ tục để lấy tên các đối tượng ra ngoài bảng tính, khi muốn xóa đối tượng nào ta chọn nó rồi xóa bằng sự kiện phải chuột hoặc đúp chuột. Không biết ý tưởng đó có làm được không (tôi thì chịu)
Có điều chắc chắn là ta không thể nhớ chính xác tên đối tượng cần xóa. Vậy cần thêm 1 thủ tục để lấy tên các đối tượng ra ngoài bảng tính, khi muốn xóa đối tượng nào ta chọn nó rồi xóa bằng sự kiện phải chuột hoặc đúp chuột. Không biết ý tưởng đó có làm được không (tôi thì chịu)
Đương nhiên được chứ anh
Ví dụ code lấy các Procedures trong 1 Module
PHP:
Function ListProcedures(ByVal ModuleName As String)
Dim LineNum As Long, NumLines As Long, i As Long, Arr(), ProcName As String
With ActiveWorkbook.VBProject.VBComponents(ModuleName).CodeModule
LineNum = .CountOfDeclarationLines + 1
Do Until LineNum >= .CountOfLines
ProcName = .ProcOfLine(LineNum, 0)
ReDim Preserve Arr(i)
Arr(i) = ProcName: i = i + 1
LineNum = .ProcStartLine(ProcName, 0) + _
.ProcCountLines(ProcName, 0) + 1
Loop
End With
ListProcedures = Arr
End Function
Áp dụng =ListProcedures("Module1") ---> Sẽ lấy tên các Procedures trong Module1
Đương nhiên được chứ anh
Ví dụ code lấy các Procedures trong 1 Module
PHP:
Function ListProcedures(ByVal ModuleName As String)
Dim LineNum As Long, NumLines As Long, i As Long, Arr(), ProcName As String
With ActiveWorkbook.VBProject.VBComponents(ModuleName).CodeModule
LineNum = .CountOfDeclarationLines + 1
Do Until LineNum >= .CountOfLines
ProcName = .ProcOfLine(LineNum, 0)
ReDim Preserve Arr(i)
Arr(i) = ProcName: i = i + 1
LineNum = .ProcStartLine(ProcName, 0) + _
.ProcCountLines(ProcName, 0) + 1
Loop
End With
ListProcedures = Arr
End Function
Áp dụng =ListProcedures("Module1") ---> Sẽ lấy tên các Procedures trong Module1
Ndu cho file ví dụ xem áp dụng như thế nào. Mình vào bảng tính (có 2 Module 1 chứa code này, 1 chứa code khác) và nhập công thức =ListProcedures("Module1") đã thử với tên Module1 và Module2 nhưng kết quả vẫn là #VALUE!
Ndu cho file ví dụ xem áp dụng như thế nào. Mình vào bảng tính (có 2 Module 1 chứa code này, 1 chứa code khác) và nhập công thức =ListProcedures("Module1") đã thử với tên Module1 và Module2 nhưng kết quả vẫn là #VALUE!
Ndu cho file ví dụ xem áp dụng như thế nào. Mình vào bảng tính (có 2 Module 1 chứa code này, 1 chứa code khác) và nhập công thức =ListProcedures("Module1") đã thử với tên Module1 và Module2 nhưng kết quả vẫn là #VALUE!
@ Ndu: Hàm ListProcedures("Module1") thì được rồi nhưng mình muốn danh sách này được liệt kê ra bảng tính mình thử code dưới thì được nhưng không biết trong Module1 có bao nhiêu Macro để thay vào cái chỗ số 5 ?
Mã:
Sub LisModule()
[d2].Resize([B][COLOR=#ff0000]5[/COLOR][/B]) = WorksheetFunction.Transpose(ListProcedures("Module1"))
End Sub
Còn vấn đề nữa là nhờ bạn giúp tiếp hàm lấy các Module của File ra ngoài bảng tính.
@ Ndu: Hàm ListProcedures("Module1") thì được rồi nhưng mình muốn danh sách này được liệt kê ra bảng tính mình thử code dưới thì được nhưng không biết trong Module1 có bao nhiêu Macro để thay vào cái chỗ số 5 ?
Mã:
Sub LisModule()
[d2].Resize([B][COLOR=#ff0000]5[/COLOR][/B]) = WorksheetFunction.Transpose(ListProcedures("Module1"))
End Sub
Còn vấn đề nữa là nhờ bạn giúp tiếp hàm lấy các Module của File ra ngoài bảng tính.
Sub LisModule()
Dim Arr
Arr = ListProcedures("Module1")
[d2].Resize(UBound(Arr) + 1) = WorksheetFunction.Transpose(ListProcedures("Module1"))
End Sub
Ubound(Arr) chính là cái anh cần
--------------------
Còn vụ lấy listModule, em nghĩ chắc là vầy:
PHP:
Function ListModule()
Dim mod_ As VBComponent
Dim n As Long
Dim Arr()
For Each mod_ In ActiveWorkbook.VBProject.VBComponents
If mod_.Type = 1 Then
n = n + 1
ReDim Preserve Arr(1 To n)
Arr(n) = mod_.Name
End If
Next
If n Then ListModule = Arr
End Function
-----------------
Oh mà xem lại thì thấy mấy bài cuối chẳng ăn nhậu gì đến vụ DÙNG CODE VBA ĐỂ XÓA VBA cả. Anh TrungChinhs có thấy vậy không?
Ẹc... Ẹc... lộn tiệm dễ bị mod xóa bài quá
Sub LisModule()
Dim Arr
Arr = ListProcedures("Module1")
[d2].Resize(UBound(Arr) + 1) = WorksheetFunction.Transpose(ListProcedures("Module1"))
End Sub
Ubound(Arr) chính là cái anh cần
--------------------
Còn vụ lấy listModule, em nghĩ chắc là vầy:
PHP:
Function ListModule()
Dim mod_ As VBComponent
Dim n As Long
Dim Arr()
For Each mod_ In ActiveWorkbook.VBProject.VBComponents
If mod_.Type = 1 Then
n = n + 1
ReDim Preserve Arr(1 To n)
Arr(n) = mod_.Name
End If
Next
If n Then ListModule = Arr
End Function
-----------------
Oh mà xem lại thì thấy mấy bài cuối chẳng ăn nhậu gì đến vụ DÙNG CODE VBA ĐỂ XÓA VBA cả. Anh TrungChinhs có thấy vậy không?
Ẹc... Ẹc... lộn tiệm dễ bị mod xóa bài quá
Ấy... ấy... sao lại không ? Tại #123 tôi đã nêu rõ mục đích rồi mà. Tôi đang muốn lấy các Module và các Macro ra ngoài bảng tính sau đó dùng code của Siwtom tại # 119 để xóa. Mấy bài vừa rồi sẽ giúp cho việc thay tên đối tượng cần xóa trong Code của Siwtom bằng Selection.value.
Nếu có thời gian thì Ndu tiếp tục xem nào. Tôi sẽ thử tiếp, chỉ hiềm một nỗi là tôi không hiểu lắm các câu lệnh nên chỉ thực hiện máy móc theo kiểu thay thế IC thôi.
Hic đọc lại bài 119 thì ra là code xóa dòng trong Macro chứ không phải là code xóa Module hoặc xóa Macro nên Botay.com luôn.
Từ 2 bài của Ndu tôi mới làm được đến đây (xem file đính kèm). Bạn nào biết, viết giúp mình code Delete Macro và Remove Module. Thanks !
Hic đọc lại bài 119 thì ra là code xóa dòng trong Macro chứ không phải là code xóa Module hoặc xóa Macro nên Botay.com luôn.
Từ 2 bài của Ndu tôi mới làm được đến đây (xem file đính kèm). Bạn nào biết, viết giúp mình code Delete Macro và Remove Module. Thanks !
Em chưa thử nên không biết.
Nhưng sắp tới Em cũng phải cần đến vấn đề này.
Nhưng ý Em hỏi là code xóa nguyên 1 tên "Sub" nào đó trong nhiều "Sub"
hoặc là xóa 1 module trong nhiều module mà....(trong 1 woorkbook).
Chứ không phải là xóa toàn bộ vba trong cửa sổ hay là xóa 1 dòng code nào trong 1 sub như anh nói.
Hic đọc lại bài 119 thì ra là code xóa dòng trong Macro chứ không phải là code xóa Module hoặc xóa Macro nên Botay.com luôn.
Từ 2 bài của Ndu tôi mới làm được đến đây (xem file đính kèm). Bạn nào biết, viết giúp mình code Delete Macro và Remove Module. Thanks !
Thì lỗi của bạn thôi. Lần sau đọc cho kỹ nhé.
Mà "xóa dòng" là không chính xác (xóa vài dòng trong SUB, trong MODULE? - làm gì có chuyện đó). Code xóa toàn bộ code của 1 hàm, phương thức có tên cho trước trong module có tên cho trước trong book cho trước.
Tôi thường đọc kỹ bài của người khác.
Code không xóa Module mà chỉ xóa hàm trong Module vì người hỏi viết: "Xin hỏi các chuyên gia có code nào xóa một sub trong module không"
Để bạn làm được các việc đã nêu thì tôi cho bạn những code dưới đây. Chú ý:
1. DeleteProcedureCode không chỉ xóa code của hàm và sub trong Module mà cả code trong UserForm, Sheet1, 2, 3, ThisWorkBook (với CompName = "UserForm1", "Sheet1", "ThisWorkBook")
2. Tôi viết các hàm liệt kê đòi hỏi thông số WorkBook vì tôi muốn viết hàm tổng quát thao tác trên WorkBook bất kỳ (khi có nhiều WorkBook mở cùng lúc) chứ không chỉ trên ActiveWorkBook.
Nếu bạn chỉ cần thao tác trên ActiveWorkBook thôi thì truyền ActiveWorkBook vào thông số.
Mã:
' [COLOR=#ff0000]liệt kê các hàm, sub có trong CompName (Sheet, ThisWorkBook, UserForm, Module)[/COLOR]
Function ListFunctions(ByVal book As Workbook, ByVal CompName As String)
' Microsoft Visual Basic for Applications Extensibility
' Trả về danh sách hàm có trong CompName
Dim currLine As Long, k As Long, name As String, Arr()
With book.VBProject.VBComponents(CompName).CodeModule
currLine = .CountOfDeclarationLines + 1
Do Until currLine >= .CountOfLines
ReDim Preserve Arr(0 To k)
name = .ProcOfLine(currLine, vbext_pk_Proc)
Arr(k) = name
currLine = currLine + .ProcCountLines(name, vbext_pk_Proc)
k = k + 1
Loop
End With
ListFunctions = Arr
End Function
'[COLOR=#ff0000] liệt kê các component (sheet, thisworkbook, userform, module, class module) có trong workbook[/COLOR]
Function ListComponents(ByVal book As Workbook)
' tham chieu: Microsoft Visual Basic for Applications Extensibility
Dim VBComp As VBIDE.VBComponent, Arr(), k As Long
For Each VBComp In book.VBProject.VBComponents
ReDim Preserve Arr(0 To k)
Arr(k) = VBComp.name
k = k + 1
Next VBComp
ListComponents = Arr
End Function
' [COLOR=#ff0000]xóa Module, Form, Class Module khỏi book[/COLOR]
Sub DeleteVBComponent(ByVal book As Workbook, ByVal CompName As String)
' cần có tham chiếu Microsoft Visual Basic for Applications Extensibility
' xóa vbcomponent có tên là CompName khỏi bảng tính wb
' vbcomponent là Module, Class Module, Form
' vd. DeleteVBComponent Workbooks("vbe.xls"), "class1"
' DeleteVBComponent Workbooks("vbe.xls"), "module3"
' DeleteVBComponent Workbooks("vbe.xls"), "myForm"
Dim VBCp As VBComponents
Application.DisplayAlerts = False
On Error Resume Next
Set VBCp = book.VBProject.VBComponents
If Not VBCp Is Nothing Then VBCp.Remove VBCp(CompName)
Set VBCp = Nothing
On Error GoTo 0
Application.DisplayAlerts = True
End Sub
' [COLOR=#ff0000]xóa nội dung của Module nhưng vẫn giữ Module[/COLOR]
Sub DeleteModuleContent(ByVal book As Workbook, ByVal CompName As String)
' cần có tham chiếu Microsoft Visual Basic for Applications Extensibility
' xóa nội dung (không xóa CompName) của module có tên là CompName trong bảng tính book
' vd. DeleteModuleContent Workbooks("vbe.xls"), "module3"
On Error Resume Next
With book.VBProject.VBComponents(CompName).CodeModule
.DeleteLines 1, .CountOfLines
End With
On Error GoTo 0
End Sub
' [COLOR=#ff0000]xóa code của hàm trong Module, UserForm, Sheet1, 2, 3, ThisWorkBook[/COLOR]
Sub DeleteProcedureCode(ByVal book As Workbook, _
ByVal CompName As String, ByVal ProcedureName As String)
' cần có tham chiếu Microsoft Visual Basic for Applications Extensibility
' xóa ProcedureName khỏi CompName trong bảng tính book
'vd. DeleteProcedureCode Workbooks("vbe.xls"), "module2", "tinh toan"
Dim VBCM As CodeModule, ProcStartLine As Long, ProcLineCount As Long
On Error Resume Next
' module có phương thức cần xóa
Set VBCM = book.VBProject.VBComponents(CompName).CodeModule
If Not VBCM Is Nothing Then
' tìm dòng đầu của phương thức (kể cả các dòng ghi chú ở trước Function, Sub ProcedureName)
' nếu trả về 0 thì có nghĩa là phương thức không tồn tại
ProcStartLine = VBCM.ProcStartLine(ProcedureName, vbext_pk_Proc)
If ProcStartLine > 0 Then
' tổng số dòng của phương thức
ProcLineCount = VBCM.ProcCountLines(ProcedureName, vbext_pk_Proc)
' xóa tất cả các dòng của phương thức
VBCM.DeleteLines ProcStartLine, ProcLineCount
End If
Set VBCM = Nothing
End If
On Error GoTo 0
End Sub
Cảm ơn Thầy Siwtom rất nhiều về những bài viết trong Topic này.
Xin lỗi thầy về vụ gõ nhầm tên, em đã sửa lại.
Còn về cách viết, đối với những vấn đề mới lạ nhiều khi em cứ bị ngô nghê như vậy mà không nhận ra.
Cảm ơn Thầy Siwtom rất nhiều về những bài viết trong Topic này.
Xin lỗi thầy về vụ gõ nhầm tên, em đã sửa lại.
Còn về cách viết, đối với những vấn đề mới lạ nhiều khi em cứ bị ngô nghê như vậy mà không nhận ra.
Về yêu cầu của bạn là liệt kê và xóa các Function và Sub (macro) thì tôi đã gửi code.
Nhưng tôi muốn sửa 2 code để có thể liệt kê và xóa cả các property procedures (các property procedures Get, Let, Set trong class module)
Dưới đây tôi gửi lại code của Sub / Function. Những chỗ mầu đỏ là được thêm vào, chỗ mầu xanh là sửa (trước đó là vbext_pk_Proc, bây giờ là ProcKind)
Bây giờ thì tôi tin là code thao tác cho Sheet, ThisWorkbook, UserForm, Module và Class Module, tức "trọn gói".
Mã:
Sub DeleteProcedureCode(ByVal wb As Workbook, _
ByVal CompName As String, ByVal ProcedureName As String)
' cần có tham chiếu Microsoft Visual Basic for Applications Extensibility
' xóa ProcedureName khỏi CompName trong bảng tính wb
'vd. DeleteProcedureCode Workbooks("vbe.xls"), "module2", "tinh toan"
Dim VBCM As CodeModule, ProcStartLine As Long, ProcLineCount As Long, [COLOR=#ff0000]ProcKind As Long[/COLOR]
' module có phương thức cần xóa
Set VBCM = wb.VBProject.VBComponents(CompName).CodeModule
If Not VBCM Is Nothing Then
[COLOR=#ff0000]On Error GoTo errHandler[/COLOR]
' tìm dòng đầu của phương thức (kể cả các dòng ghi chú ở trước Function, Sub ProcedureName)
' nếu trả về 0 thì có nghĩa là phương thức không tồn tại
ProcStartLine = VBCM.ProcStartLine(ProcedureName, [COLOR=#0000ff]ProcKind[/COLOR])
If ProcStartLine > 0 Then
' tổng số dòng của phương thức
ProcLineCount = VBCM.ProcCountLines(ProcedureName,[COLOR=#0000ff] ProcKind[/COLOR])
' xóa tất cả các dòng của phương thức
VBCM.DeleteLines ProcStartLine, ProcLineCount
End If
Set VBCM = Nothing
End If
Exit Sub
[COLOR=#ff0000]errHandler:
If Err.Number = 35 And ProcKind < 3 Then
ProcKind = ProcKind + 1
Resume
End If
[/COLOR]End Sub
Function ListFunctions(ByVal wb As Workbook, ByVal CompName As String)
' Microsoft Visual Basic for Applications Extensibility
' Trả về danh sách hàm có trong module
Dim currLine As Long, k As Long, name As String, Arr(), size As Long, [COLOR=#ff0000]ProcKind As Long[/COLOR]
With wb.VBProject.VBComponents(CompName).CodeModule
currLine = .CountOfDeclarationLines + 1
[COLOR=#ff0000]On Error GoTo errHandler[/COLOR]
Do Until currLine >= .CountOfLines
ReDim Preserve Arr(0 To k)
name = .ProcOfLine(currLine, [COLOR=#0000ff]ProcKind[/COLOR])
Arr(k) = name
currLine = currLine + .ProcCountLines(name, [COLOR=#0000ff]ProcKind[/COLOR])
k = k + 1
Loop
End With
ListFunctions = Arr
Exit Function
[COLOR=#ff0000]errHandler:
If Err.Number = 35 And ProcKind < 3 Then
ProcKind = ProcKind + 1
Resume
End If
[/COLOR]End Function
Cần gì phải đau khổ đến thế chứ, muốn xây thì khó chứ đập ra thì nhanh lắm
PHP:
Sub Xoa_Modules()
Dim x
On Error Resume Next
With ActiveWorkbook.VBProject
For x = .VBComponents.Count To 1 Step -1
.VBComponents.Remove .VBComponents(x)
Next x
End With
End Sub
Còn việc Saveas thì có thể dùng thêm dòng lệnh Application.displayalerts=False để lưu đè lên file gốc rồi mà, đâu cần phải xoá nữa
Nếu bạn biết viết code rồi thì cái này đơn giản mà
Phát hiện thêm 1 chuyện nữa: Sau khi gọi hết tất cả các Add-Ins của MS lên (đương nhiên mấy Add-Ins này đều có Pass). Sau đó chạy code của siwtom thì toàn bộ các Add-Ins đều "mở cửa" ---> Xem code thoải mái Quá sốc!
Anh có thể cho em biết nếu đoạn code sau khi sử dụng với office 64b thì nên sửa thế nào không ạ.
Mã:
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Long, Source As Long, ByVal Length As Long)
Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Long, _
ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, _
ByVal lpProcName As String) As Long
Private Declare Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As Long, _
ByVal pTemplateName As Long, ByVal hWndParent As Long, _
ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer
Xin hỏi anh và các anh chị trên diễn đàn!.
Tôi sử dụng file thì thấy code báo lỗi đoạn code sau: (Tôi sử dụng Win 10 và office 2013) mong anh chị giúp
Option Explicit
Private Const PAGE_EXECUTE_READWRITE = &H40
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Long, Source As Long, ByVal Length As Long)
Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Long, _
ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, _
ByVal lpProcName As String) As Long
Private Declare Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As Long, _
ByVal pTemplateName As Long, ByVal hWndParent As Long, _
ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer
Dim HookBytes(0 To 5) As Byte
Dim OriginBytes(0 To 5) As Byte
Dim pFunc As Long
Dim Flag As Boolean