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

Liên hệ QC
Quang_Hải

Quang_Hải

Thành viên gạo cội
Tham gia
21/2/09
Bài viết
6,051
Được thích
7,953
Nghề nghiệp
Làm đủ thứ
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
 
Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Để đọ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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
Thì vẫn vậy hehe :D
 
Upvote 0
Cậu download file test1.xlxm tôi vừa up lại thử
 
Upvote 0
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
......
 
Lần chỉnh sửa cuối:
Upvote 0
ThangCuAnh đã viết:
Cậu download file test1.xlxm tôi vừa up lại thử
Nhấp chuột vào đây để mở rộng...
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:

Untitled.jpg


Đ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

Untitled2.jpg


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

Untitled3.jpg

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)
 
Upvote 0
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
 
Upvote 0
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"
......
Nhấp chuột vào đây để mở rộng...
chia Buồn tiếp .............. Vẫn vậy .............. chỉ code Mạnh cho Linh đó Quanghai1969 viết ....ok
mmmmmmmmmmmm.PNG

Trong Registry đúng của Mình như sau:
regKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM"
 
Lần chỉnh sửa cuối:
Upvote 0
Để 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.
 
Lần chỉnh sửa cuối:
Upvote 0
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.
Nhấp chuột vào đây để mở rộng...
Thử cái này của Quanghai1969 xem sao
 

File đính kèm

  • Change TrustAccess.xlsb
    17.3 KB · Đọc: 9
Upvote 0
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è ;)
 
Upvote 0
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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
Tôi vừa test thử 2 máy ở xưởng Win XP 32 và Win7 64, Office 2017, chạy tốt
 
Upvote 0
Upvote 0
dwRet đấy.
Bạn nào dùng Office 97 hay 2003 test giúp mình nhé
 

File đính kèm

  • test1.xls
    31.5 KB · Đọc: 6
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

M
Free connections, find your partner without obligations
Trả lời
0
Đọc
1
minh2711
M
V
  • Question
GIúp code xóa các tên mặt hàng trùng nhau, chỉ chừa lại tên cho dòng trên cùng
Trả lời
1
Đọc
23
BuiQuangThuan
B
Hoangquyenbong
  • Question
Lấy hệ số tương ứng cho mã hàng xuất.
Trả lời
2
Đọc
62
Hoangquyenbong
Hoangquyenbong
H
Tính tổng có điều kiện
2
Trả lời
22
Đọc
428
hoaiantrinh
H
L
[xin nhờ giúp đỡ] hàm trích xuất ra dữ liệu thỏa mã điều kiện và ghi vào một ô
Trả lời
12
Đọc
482
VetMini
V
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom