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
Khi chep vo bị lỗi chỗ code : msgbox ""Code Created"" ... tôi add code code vô bỏ msgbox thì lỗi
help me
 
Upvote 0
ndu96081631 đã viết:
Cho "rừng" code này vào 1 Module:
Mã: 
Private Sub ChangeVBOM()
  Dim regKey As String
  regKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM"
  CreateObject("WScript.Shell").RegWrite regKey, 1, "REG_DWORD"
End Sub
Private Function IsVBATrusted() As Boolean
  Application.Volatile
  On Error Resume Next
  IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing
End Function
Sub Main()
  Dim strCode As String, bChk As Boolean
  strCode = "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curRow"", RefersToR1C1:=""=1""" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curCol"", RefersToR1C1:=""=1""" & vbLf & _
            "End Sub"
  bChk = IsVBATrusted
  If bChk = False Then ChangeVBOM
  bChk = IsVBATrusted
  If bChk Then
    On Error Resume Next
    With ActiveWorkbook.VBProject.VBComponents("Thisworkbook").CodeModule
      .DeleteLines 1, .CountOfLines
      On Error GoTo 0
      .AddFromString (strCode)
    End With
  End If
End Sub
Chạy sub Main và kiểm tra kết quả
Nhấp chuột vào đây để mở rộng...
Chào ndu,
Mình copy đoạn code này của bạn và phát sinh lỗi như hình. Mình có đổi HKEY_LOCAL_MACHINE thành HKEY_CURRENT_USER như bạn siwtom hướng dẫn, nhưng không thấy code được thêm vào Thiswworkbook.
Nhờ ndu giúp đỡ.
Cảm ơn.
 

File đính kèm

  • Lỗi.png
    Lỗi.png
    27.6 KB · Đọc: 8
Upvote 0
Trường An Nguyễn đã viết:
Chào ndu,
Mình copy đoạn code này của bạn và phát sinh lỗi như hình. Mình có đổi HKEY_LOCAL_MACHINE thành HKEY_CURRENT_USER như bạn siwtom hướng dẫn, nhưng không thấy code được thêm vào Thiswworkbook.
Nhờ ndu giúp đỡ.
Cảm ơn.
Nhấp chuột vào đây để mở rộng...
Bạn thử làm bằng tay bỏ check (hoặc check) mục "Trust access to.... " trong Excel Options rồi chạy lại code xem sao


Untitled.jpg
 
Upvote 0
Bạn sửa code hàm ChangeVBOM lại như dưới đây và test thử nhé
Mã: 
Private Sub ChangeVBOM()
    Dim regKey As String
    Dim dwRet As Long
    Dim WshShell As Object
  
    Set WshShell = CreateObject("WScript.Shell")
    regKey = "HKCU\Software\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM"
  
    On Error Resume Next
    dwRet = WshShell.RegRead(regKey)
    If (0 = dwRet) Or (Err.Number <> 0) Then
        Err.Clear
        WshShell.RegWrite regKey, 1, "REG_DWORD"
    End If
End Sub

HKCU = HKEY_CURRENT_USER
HKLM = HKEY_LOCAL_MACHINE
Dùng key nào cũng được, HKLM thì tác dụng với all user, còn HKCU thì tác dụng với current user
 
Upvote 0
Phát hiện ra chuyện "động trời" rằng:
- Cho dù Registry đã thay đổi (AccessVBOM đã được gán = 1) nhưng Excel vẫn chưa cập nhật (Trust access to... vẫn chưa được check)
- Đôi lúc key Security không tồn tại trên một vài máy, mất công phải tạo bằng tay hoặc phải viết code để tạo ra nó trước
vân... vân...
Khá rắc rối!
Thôi thì SendKeys cho khỏe (Alt + T + M + S)
Mã: 
Private Function IsVBATrusted() As Boolean
  Application.Volatile
  On Error Resume Next
  IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing
End Function
Sub Main()
  Dim n As Long, strCode As String
  strCode = "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curRow"", RefersToR1C1:=""=1""" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curCol"", RefersToR1C1:=""=1""" & vbLf & _
            "End Sub"
  If IsVBATrusted = False Then
    For n = 1 To 3
      SendKeys ("%tms%v{ENTER}")
      DoEvents
      If IsVBATrusted = True Then Exit For
    Next
  End If
  If IsVBATrusted Then
    On Error Resume Next
    With ActiveWorkbook.VBProject.VBComponents("Thisworkbook").CodeModule
      .DeleteLines 1, .CountOfLines
      On Error GoTo 0
      .AddFromString (strCode)
    End With
  End If
End Sub
 
Upvote 0
ndu96081631 đã viết:
Phát hiện ra chuyện "động trời" rằng:
- Cho dù Registry đã thay đổi (AccessVBOM đã được gán = 1) nhưng Excel vẫn chưa cập nhật (Trust access to... vẫn chưa được check)
- Đôi lúc key Security không tồn tại trên một vài máy, mất công phải tạo bằng tay hoặc phải viết code để tạo ra nó trước
vân... vân...
Khá rắc rối!
Thôi thì SendKeys cho khỏe (Alt + T + M + S)
Mã: 
Private Function IsVBATrusted() As Boolean
  Application.Volatile
  On Error Resume Next
  IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing
End Function
Sub Main()
  Dim n As Long, strCode As String
  strCode = "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curRow"", RefersToR1C1:=""=1""" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curCol"", RefersToR1C1:=""=1""" & vbLf & _
            "End Sub"
  If IsVBATrusted = False Then
    For n = 1 To 3
      SendKeys ("%tms%v{ENTER}")
      DoEvents
      If IsVBATrusted = True Then Exit For
    Next
  End If
  If IsVBATrusted Then
    On Error Resume Next
    With ActiveWorkbook.VBProject.VBComponents("Thisworkbook").CodeModule
      .DeleteLines 1, .CountOfLines
      On Error GoTo 0
      .AddFromString (strCode)
    End With
  End If
End Sub
Nhấp chuột vào đây để mở rộng...


Nếu thế thì chơi kiểu:
1, Check xem nó bật chưa ( dùng IsVBATrusted)
2, Nếu chưa bật thì ta bật nó ( dùng reg)
3, Check lại xem nó bật chưa( IsVBATrusted). Nếu nó vẫn chưa bật thì kểu người dùng khởi động lại Excel.
 
Upvote 0
NguyenNgocThuHien đã viết:
Nếu thế thì chơi kiểu:
1, Check xem nó bật chưa ( dùng IsVBATrusted)
2, Nếu chưa bật thì ta bật nó ( dùng reg)
3, Check lại xem nó bật chưa( IsVBATrusted). Nếu nó vẫn chưa bật thì kểu người dùng khởi động lại Excel.
Nhấp chuột vào đây để mở rộng...
Thì lúc đầu mình làm vậy đấy!
Vấn đề là khi ghi giá trị AccessVBOM = 1 vào Registry rồi nhưng Excel vẫn chưa cập nhật trạng thái. Khi ấy nếu dùng hàm IsVBATrusted để kiểm tra vẫn nhận giá trị = FALSE
Nếu kêu người dùng khởi động Excel thì thôi thà tôi làm vầy:
- Dùng hàm IsVBATrusted kiểm tra
- Nếu kết quả quả hàm = FALSE, xuất hiện thông báo kêu người dùng vào Excel Options\Trust Center\Trust Center Setting\Macro Settings rồi tự check bằng tay vào mục "Trus access to...."
Vậy cho khỏe
Ở đây mình muốn mọi thứ tự động hơn! Bạn có ý tưởng gì không?
 
Upvote 0
ndu96081631 đã viết:
Thì lúc đầu mình làm vậy đấy!
Vấn đề là khi ghi giá trị AccessVBOM = 1 vào Registry rồi nhưng Excel vẫn chưa cập nhật trạng thái. Khi ấy nếu dùng hàm IsVBATrusted để kiểm tra vẫn nhận giá trị = FALSE
Nếu kêu người dùng khởi động Excel thì thôi thà tôi làm vầy:
- Dùng hàm IsVBATrusted kiểm tra
- Nếu kết quả quả hàm = FALSE, xuất hiện thông báo kêu người dùng vào Excel Options\Trust Center\Trust Center Setting\Macro Settings rồi tự check bằng tay vào mục "Trus access to...."
Vậy cho khỏe
Ở đây mình muốn mọi thứ tự động hơn! Bạn có ý tưởng gì không?
Nhấp chuột vào đây để mở rộng...
Em thấy Anh Quanghai1969 trước đây có viết rùi hay sao ấy ... chạy ok ..........
http://www.giaiphapexcel.com/dienda...ổ-vba-trust-center-bằng-code-vba.99865/page-2
 
Lần chỉnh sửa cuối:
Upvote 0
ndu96081631 đã viết:
Thì lúc đầu mình làm vậy đấy!
Vấn đề là khi ghi giá trị AccessVBOM = 1 vào Registry rồi nhưng Excel vẫn chưa cập nhật trạng thái. Khi ấy nếu dùng hàm IsVBATrusted để kiểm tra vẫn nhận giá trị = FALSE
Nếu kêu người dùng khởi động Excel thì thôi thà tôi làm vầy:
- Dùng hàm IsVBATrusted kiểm tra
- Nếu kết quả quả hàm = FALSE, xuất hiện thông báo kêu người dùng vào Excel Options\Trust Center\Trust Center Setting\Macro Settings rồi tự check bằng tay vào mục "Trus access to...."
Vậy cho khỏe
Ở đây mình muốn mọi thứ tự động hơn! Bạn có ý tưởng gì không?
Nhấp chuột vào đây để mở rộng...
Khó thế thì làm bằng tay thôi, chứ code củng làm gì. Hacker thì mới cần những cách để tự động hóa can thiết vào cái này. Mà nếu ngại thì có thể tự động đóng excel và khởi động lại.
 
Upvote 0
Vậy là cái Vụ này lùm xùm từ Năm 2014 To 2018 .................. tính Năm là 4............... vậy mà vẫn chưa thỏa mãn kể ra khó thiệt ............-0-0-0-
 
Upvote 0
Upvote 0
Bà con test lại code sau giúp cu anh em thử nhé, em test thấy OK rồi đó:
Mã: 
Option Explicit

Private Sub ChangeVBOM()
    Dim regKey As String
    Dim dwRet As LongPtr
    Dim WshShell As Object
 
    Set WshShell = CreateObject("WScript.Shell")
    regKey = "HKLM\Software\Policies\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM"

    On Error Resume Next
    dwRet = WshShell.RegRead(regKey)
    If (0 = dwRet) Or (Err.Number <> 0) Then
        Err.Clear
        WshShell.RegWrite regKey, 1, "REG_DWORD"
        If Err.Number <> 0 Then MsgBox "RegWrite failed: " & Err.Description, vbCritical
    End If
End Sub

Private Function IsVBATrusted() As Boolean
    Application.Volatile
    On Error Resume Next
    IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing
End Function

Sub Main()
    Dim strCode As String, bChk As Boolean
 
    strCode = "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbLf & _
            vbTab & "ActiveWorkbook.Names.Add Name:=""curRow"", RefersToR1C1:=""=1""" & vbLf & _
            vbTab & "ActiveWorkbook.Names.Add Name:=""curCol"", RefersToR1C1:=""=1""" & vbLf & _
            "End Sub"
 
    bChk = IsVBATrusted
    If Not bChk Then
        ChangeVBOM
        bChk = IsVBATrusted
    End If
 
    If bChk Then
        On Error Resume Next
        With ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
            .DeleteLines 1, .CountOfLines
            On Error GoTo 0
            .AddFromString strCode
            MsgBox "Hehe, all OK :)"
        End With
    Else
        MsgBox "Ac ac, lai failed tiep :("
    End If
End Sub

Y code anh Du thôi, chỉ khác xíu xìu xiu :)

Quan trọng là key này: HKLM\SOFTWARE\Policies\Microsoft\Office\xx.x\Excel\Security
Nó làm em mất gần cả ngày không đi làm, ngồi reverse, debug, monitor API call....
 

File đính kèm

  • test1.xlsm
    17.4 KB · Đọc: 16
Lần chỉnh sửa cuối:
Upvote 0
Ngoài thư viện VBExxx.dll, Excel và các ứng dụng của Office dùng 1 core dll khác vô cùng quan trọng là MSO.DLL.
Toàn bộ các options save trong Registry, Excel phải thông qua các hàm MsoFRead/WriteXXX export từ MSO.DLL
Khi truy xuất VBA code, MSO liên tục query các value từ registry key HKLM\Software\Policies\Micorost\Office\xx.x\Security
Ác cái ông MSO.dll này không có debug PDB symbol file nên em reverse chay tới mờ mắt, hè hè
 
Upvote 0
ThangCuAnh đã viết:
Bà con test lại code sau giúp cu anh em thử nhé, em test thấy OK rồi đó:
Mã: 
Option Explicit

Private Sub ChangeVBOM()
    Dim regKey As String
    Dim dwRet As LongPtr
    Dim WshShell As Object
 
    Set WshShell = CreateObject("WScript.Shell")
    regKey = "HKLM\Software\Policies\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM"

    On Error Resume Next
    dwRet = WshShell.RegRead(regKey)
    If (0 = dwRet) Or (Err.Number <> 0) Then
        Err.Clear
        WshShell.RegWrite regKey, 1, "REG_DWORD"
    End If
End Sub

Private Function IsVBATrusted() As Boolean
    Application.Volatile
    On Error Resume Next
    IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing
End Function

Sub Main()
    Dim strCode As String, bChk As Boolean
 
    strCode = "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbLf & _
            vbTab & "ActiveWorkbook.Names.Add Name:=""curRow"", RefersToR1C1:=""=1""" & vbLf & _
            vbTab & "ActiveWorkbook.Names.Add Name:=""curCol"", RefersToR1C1:=""=1""" & vbLf & _
            "End Sub"
 
    bChk = IsVBATrusted
    If Not bChk Then
        ChangeVBOM
        bChk = IsVBATrusted
    End If
 
    If bChk Then
        On Error Resume Next
        With ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
            .DeleteLines 1, .CountOfLines
            On Error GoTo 0
            .AddFromString strCode
            MsgBox "Hehe, all OK :)"
        End With
    Else
        MsgBox "Ac ac, lai failed tiep :("
    End If
End Sub

Y code anh Du thôi, chỉ khác xíu xìu xiu :)

Quan trọng là key này: HKLM\SOFTWARE\Policies\Microsoft\Office\14.0\Excel\Security
Nó làm em mất gần cả ngày không đi làm, ngồi reverse, debug, monitor API call....
Nhấp chuột vào đây để mở rộng...
Xin chia Buồn là chạy mấy cái nó cứ Im Re không nhúc nhíc .....

Sử dụng Windws10_x64 + Office 2016_x32
 
Upvote 0
Bạn chạy debug step thử. Máy tôi Win7 x64, Office 2010 64bit. Nó phải show msgbox failed hay OK chứ :)
 
Upvote 0
Không hiện Msgbox nào à ? Chạy macro Sub Main() phải không bạn ?
 
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

L
Tạo hàm Round cho nhiều dòng
Trả lời
9
Đọc
6K
KenJayce
K
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
3
Đọc
64
Phan Thế Hiệp
Phan Thế Hiệp
phunguyenkt
  • Question
MN cho em xin phần mềm chuyển đổi số sang chữ với ạ, và ko có chữ chẵn, em cảm ơn
Trả lời
3
Đọc
180
le_vis
L
N
Tổng hợp phiếu lấy ý kiến của GV, NV trong trường học
Trả lời
1
Đọc
19
Hoàng Tuấn 868
H
Hoangquyenbong
  • Question
Lấy hệ số tương ứng cho mã hàng xuất.
Trả lời
2
Đọc
75
Hoangquyenbong
Hoangquyenbong
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