Tự động chèn code vào sheet của 1 File Excel

Quang_Hải · 1/5/13

Mình mở chủ đề này để giới thiệu cho các bạn nào quan tâm đến việc tự động chèn code vào 1 file excel nào đó.
Giả định trên file hiện tại có 1 sheet mang tên là "ABC", giờ ta muốn chèn code vào sheet này
Để phát triển thêm ta có thể thay ActiveWorkBook bằng tên của File ta cần chèn code

PHP:

Sub add_code_to_existing_sheet()
Dim CodeLines As Long, sheetCode
   sheetCode = ActiveWorkbook.Sheets("ABC").CodeName
   With ActiveWorkbook.VBProject.VBComponents(sheetCode).CodeModule
        CodeLines = .CountOfLines + 1
        .InsertLines CodeLines, _
            "Private Sub Worksheet_SelectionChange(ByVal Target As Range)" & Chr(13) & _
            "     MsgBox ""Code Created"" " & Chr(13) & _
            "End Sub"
    End With
End Sub

Ta cũng có thể tạo ra 1 sheet mới rồi chèn code vào sheet vừa được tạo bằng code bên dưới.

PHP:

Sub add_code_to_NewSheet()
Dim CodeLines As Long
   Sheets.Add
   With ActiveWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
        CodeLines = .CountOfLines + 1
        .InsertLines CodeLines, _
            "Private Sub Worksheet_SelectionChange(ByVal Target As Range)" & Chr(13) & _
            "     msgbox ""Code Created"" " & Chr(13) & _
            "End Sub"
    End With
End Sub

Nếu cần chèn code vào WorkBook ta áp dụng code này

PHP:

Sub add_code_to_thisworkbook()
Dim CodeLines As Long
   With ActiveWorkbook.VBProject.VBComponents("Thisworkbook").CodeModule
        CodeLines = .CountOfLines + 1
        .InsertLines CodeLines, _
            "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & Chr(13) & _
            "     msgbox ""Code Created"" " & Chr(13) & _
            "End Sub"
    End With
End Sub

Nếu cần thêm 1 module mới rồi chèn code vào module này thì ta làm như code bên dưới.
Chú ý: Để chèn được Module thì phải vào Tools, tìm và chọn mục Microsoft Visual Basic for Appliations extensibility 5.3
Hoặc khi viết code đến dòng ActiveWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule) thì Excel sẽ tự động hỏi mình có muốn chọn mục này hay không.

PHP:

Sub Add_Module_and_Code()
Dim CodeLines As Long, VBComp
   Set VBComp = ActiveWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule)
   With ActiveWorkbook.VBProject.VBComponents(VBComp.Name).CodeModule
        CodeLines = .CountOfLines + 1
        .InsertLines CodeLines, _
            "Sub Add_Module_and_Code" & Chr(13) & _
            "     msgbox ""Code Created"" " & Chr(13) & _
            "End Sub"
    End With
End Sub

Hy vọng là bài viết hữu ích cho những bạn mới học VBA

Kiều Mạnh · 2/1/18

ThangCuAnh đã viết:
Để đọc và viết vào HKEY_LOCAL_MACHINE, user phải có quyền admin.
Cậu thêm dòng code sau vào sau đoạn WshShell.RegWrite thử xem

Mã:

WshShell.RegWrite regKey, 1, "REG_DWORD" If Err.Number <> 0 Then MsgBox "RegWrite failed: " & Err.Description, vbCritical

Thì vẫn vậy hehe

ThangCuAnh · 2/1/18

Cậu download file test1.xlxm tôi vừa up lại thử

Kiều Mạnh · 2/1/18

ThangCuAnh đã viết:
Cậu download file test1.xlxm tôi vừa up lại thử

Chạy mấy cái nó vẫn vậy ...........

Tham khảo code link sau .... OK
http://www.giaiphapexcel.com/dienda...ổ-vba-trust-center-bằng-code-vba.99865/page-2

ThangCuAnh · 2/1/18

Tôi không có Office 2016 nên không test được. Các bạn khác test thử.
Mục đích code này là tránh SendKeys, tránh restart Excel, tránh show cái Option Dialog Trust Center đó.
Hè hè, tìm ra rồi, cậu chạy Office x86 trên Win64 nên registry bị khác rồi.
Cậu sữa lại code như dưới và test thử nhé, nhớ debug, step vào nhé

Mã:

Private Sub ChangeVBOM(ByVal regKey As String)
..........
Sub Main()
...........
    regKey1 = "HKLM\Software\Policies\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM"
#If Win64 Then
    regKey2 = "HKLM\Software\Wow6432Node\Policies\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM"
#End If
......

ndu96081631 · 2/1/18

ThangCuAnh đã viết:
Cậu download file test1.xlxm tôi vừa up lại thử

Tôi bỏ dòng On Error Resume Next trong Sub ChangeVBOM rồi chạy Sub Main, nhận được thông báo lỗi:

Đoán là key không tồn tại. Kiểm tra Registry thấy đúng là vậy nên tôi tạo key ấy bằng tay

Xong chạy lại code ----> Vẫn lỗi ấy xuất hiện. Quan trọng hơn, khi tạo key ấy bằng tay xong, kiểm tra Excel Options thấy mục "Trust access to... " bị mờ luôn

Tôi thử xóa (bằng tay) mục AccessVBOM vừa tạo thì chuyện lạ xảy ra: Thằng "Trust access to... " trong Excel Options hiện lên trở lại đồng thời nó đã được check từ đời nào không biết
---------------------------
Nói chung là không hiểu
(Tôi dùng Win10 + Office 2016, tất cả đều 32 bit)

ThangCuAnh · 2/1/18

Hàm WshShell.RegRead sẽ throw error nếu key không exists, nhưng hàm WshShell.RegWrite sẽ tự tạo key, nên anh không cần tạo = tay

ndu96081631 · 2/1/18

ThangCuAnh đã viết:
Hàm WshShell.RegRead sẽ throw error nếu key không exists, nhưng hàm WshShell.RegWrite sẽ tự tạo key, nên anh không cần tạo = tay

Test trên máy tôi không thấy có vụ tự tạo key như bạn nói

Kiều Mạnh · 2/1/18

ThangCuAnh đã viết:
Tôi không có Office 2016 nên không test được. Các bạn khác test thử.
Mục đích code này là tránh SendKeys, tránh restart Excel, tránh show cái Option Dialog Trust Center đó.
Hè hè, tìm ra rồi, cậu chạy Office x86 trên Win64 nên registry bị khác rồi.
Cậu sữa lại code như dưới và test thử nhé, nhớ debug, step vào nhé

Mã:

Private Sub ChangeVBOM(ByVal regKey As String) .......... Sub Main() ........... regKey1 = "HKLM\Software\Policies\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM" regKey2 = "HKLM\Software\Wow6432Node\Policies\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM" ......

chia Buồn tiếp .............. Vẫn vậy .............. chỉ code Mạnh cho Linh đó Quanghai1969 viết ....ok

Trong Registry đúng của Mình như sau:
regKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM"

ThangCuAnh · 2/1/18

Để các bạn khác test trên các bản Office khác xem sao, he he

"HKLM\Software\Policies\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM" có quyền cao hơn cậu à. Không tin cậu test với value 1 ở HKCU, value 0 ở HKLM Policies, rồi mở Excel, mở Trust Center ra xem.

Kiều Mạnh · 2/1/18

ThangCuAnh đã viết:
Để các bạn khác test trên các bản Office khác xem sao, he he
"HKLM\Software\Policies\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM" có quyền cao hơn cậu à. Không tin cậu test với value 1 ở HKCU, value 0 ở HKLM Policies, rồi mở Excel, mở Trust Center ra xem.

Thử cái này của Quanghai1969 xem sao

ThangCuAnh · 2/1/18

Hì hì, tôi đã nói không dùng SendKey mà, nhá lên 1 cái khó chịu.
Tôi test rồi, nếu máy tôi
"HKLM\Software\Policies\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM" là 0 thì code đó vẫn failed.
Do cái ông On Error Resume Next nên thấy báo OK thì tưởng được, debug ra thì failed tè lè

moctriet · 2/1/18

Nhấn Alt + F8 để chạy, còn không add vào một button

#If VBA7 Then
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Sub CheckTrustAccess()
Dim strStatus, strOpp, strCheck As String
Dim bEnabled As Boolean
If Not VBAIsTrusted Then
'ask the user if they want me to try to programatically toggle trust access. If I fail, give them directions.
bEnabled = False
strStatus = "DISABLE"
strOpp = "ENABLE"
vnpace = 6
Else
bEnabled = True
strStatus = "ENABLE"
strOpp = "DISABLE"
vnpace = MsgBox("Trust Access to the VBA Project Object Model is " & strStatus & "D." & Chr(10) & Chr(10) & _
"Would you like me to attempt to " & strOpp & " it?", vbYesNo, strOpp & " Trust Access?")
End If

If vnpace = 6 Then
'try to toggle trust
Call ToggleTrust(bEnabled)
Else
MsgBox "To manually " & strOpp & " Trust Access:" & Chr(10) & Chr(10) & _
Space(5) & "1) Click " & Chr(145) & "File-> Options-> Trust Center-> Trust Center Settings" & Chr(146) & Chr(10) & _
Space(5) & "2) Click Macro Settings" & Chr(10) & _
Space(5) & "3) Toggle the box next to ""Trust Access to the VBA project object model""", vbOKOnly, "How to " & strOpp & " Trust Access"
End
End If

If VBAIsTrusted Then
'if you want to write your own macro, do it here. You only get here if access is trusted
End If

End Sub

Private Function VBAIsTrusted() As Boolean
Dim a1 As Integer
On Error GoTo Label1
a1 = ActiveWorkbook.VBProject.VBComponents.Count
VBAIsTrusted = True
Exit Function
Label1:
VBAIsTrusted = False
End Function

Private Sub ToggleTrust(bEnabled As Boolean)
Dim b1 As Integer, i As Integer
Dim strkeys As String
On Error Resume Next
Do While i <= 2 'try to sendkeys 3 times
Sleep 100
strkeys = "%tms%v{ENTER}"
Call SendKeys(Trim(strkeys)) 'ST%V{ENTER}")
DoEvents
If VBAIsTrusted <> bEnabled Then Exit Do 'successfully toggled trust
Sleep (100)
i = i + 1
Loop
End Sub

ndu96081631 · 3/1/18

moctriet đã viết:
Nhấn Alt + F8 để chạy, còn không add vào một button

#If VBA7 Then
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Sub CheckTrustAccess()
Dim strStatus, strOpp, strCheck As String
Dim bEnabled As Boolean
If Not VBAIsTrusted Then
'ask the user if they want me to try to programatically toggle trust access. If I fail, give them directions.
bEnabled = False
strStatus = "DISABLE"
strOpp = "ENABLE"
vnpace = 6
Else
bEnabled = True
strStatus = "ENABLE"
strOpp = "DISABLE"
vnpace = MsgBox("Trust Access to the VBA Project Object Model is " & strStatus & "D." & Chr(10) & Chr(10) & _
"Would you like me to attempt to " & strOpp & " it?", vbYesNo, strOpp & " Trust Access?")
End If

If vnpace = 6 Then
'try to toggle trust
Call ToggleTrust(bEnabled)
Else
MsgBox "To manually " & strOpp & " Trust Access:" & Chr(10) & Chr(10) & _
Space(5) & "1) Click " & Chr(145) & "File-> Options-> Trust Center-> Trust Center Settings" & Chr(146) & Chr(10) & _
Space(5) & "2) Click Macro Settings" & Chr(10) & _
Space(5) & "3) Toggle the box next to ""Trust Access to the VBA project object model""", vbOKOnly, "How to " & strOpp & " Trust Access"
End
End If

If VBAIsTrusted Then
'if you want to write your own macro, do it here. You only get here if access is trusted
End If

End Sub

Private Function VBAIsTrusted() As Boolean
Dim a1 As Integer
On Error GoTo Label1
a1 = ActiveWorkbook.VBProject.VBComponents.Count
VBAIsTrusted = True
Exit Function
Label1:
VBAIsTrusted = False
End Function

Private Sub ToggleTrust(bEnabled As Boolean)
Dim b1 As Integer, i As Integer
Dim strkeys As String
On Error Resume Next
Do While i <= 2 'try to sendkeys 3 times
Sleep 100
strkeys = "%tms%v{ENTER}"
Call SendKeys(Trim(strkeys)) 'ST%V{ENTER}")
DoEvents
If VBAIsTrusted <> bEnabled Then Exit Do 'successfully toggled trust
Sleep (100)
i = i + 1
Loop
End Sub

Thế code này khác gì so với code của tôi ở bài 25?
Ở đây người ta muốn có cách nào đó hoàn hảo hơn chứ vẫn sendkeys thì nói làm gì nữa

ThangCuAnh · 3/1/18

Tôi vừa test thử 2 máy ở xưởng Win XP 32 và Win7 64, Office 2017, chạy tốt

Kiều Mạnh · 3/1/18

ThangCuAnh đã viết:
Tôi vừa test thử 2 máy ở xưởng Win XP 32 và Win7 64, Office 2017, chạy tốt

đang rảnh úp file cho mình thử tí

ThangCuAnh · 3/1/18

File test1.xlsm đấy, mình đã up ở trước. Sửa LongPtr lại thành Long
http://www.giaiphapexcel.com/dienda...eet-của-1-file-excel.80149/page-2#post-835282

Kiều Mạnh · 3/1/18

ThangCuAnh đã viết:
File test1.xlsm đấy, mình đã up ở trước. Sửa LongPtr lại thành Long
http://www.giaiphapexcel.com/diendan/threads/tự-động-chèn-code-vào-sheet-của-1-file-excel.80149/page-2#post-835282

thấy như củ có cái Hàm API nào mô mà Sửa LongPtr lại thành Long

ThangCuAnh · 3/1/18

dwRet đấy.
Bạn nào dùng Office 97 hay 2003 test giúp mình nhé

Kiều Mạnh · 3/1/18

ThangCuAnh đã viết:
dwRet đấy

sửa vầy chứ gì Dim dwRet As Long

chạy mấy cái vẫn vẫn failed

ThangCuAnh · 3/1/18

Bạn có quyền admin không, Win gì bạn, Office gì bạn ?
Để mình cài Office 2016 test thử.

Tự động chèn code vào sheet của 1 File Excel

Thành viên gạo cội

I don't program, I beat code into submission!!!

Mới rờ Ét xeo

I don't program, I beat code into submission!!!

Mới rờ Ét xeo

Huyền thoại GPE

Mới rờ Ét xeo

Huyền thoại GPE

I don't program, I beat code into submission!!!

Mới rờ Ét xeo

I don't program, I beat code into submission!!!

File đính kèm

Mới rờ Ét xeo

Thành viên thường trực

Huyền thoại GPE

Mới rờ Ét xeo

I don't program, I beat code into submission!!!

Mới rờ Ét xeo

I don't program, I beat code into submission!!!

Mới rờ Ét xeo

File đính kèm

I don't program, I beat code into submission!!!

Mới rờ Ét xeo

Đếm ngược thời gian