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,070
Được thích
7,992
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
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

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
Để đọ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
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

HeSanbi
  • Đã giải quyết
ExplorerXL - Quản lý thư mục với Excel: tìm, đổi tên, sao chép, di chuyển và xóa
    • Thích
    • Yêu thích
    • Cảm ơn
3 4 5
Trả lời
80
Đọc
16K
ngochienbmt
N
Manhhung90
  • Question Question
Xin giúp chuyển dữ liệu từ cột dọc sang hàng ngang theo điều kiện
    • Buồn
Trả lời
8
Đọc
150
Manhhung90
Manhhung90
T
cách viết hàm if
Trả lời
4
Đọc
131
VetMini
V
hahuykhuong
  • Question Question
link file pdf hóa đơn bằng vba
Trả lời
1
Đọc
47
zzzsxxx01
Z
X
Tự động giãn dòng và ẩn các dòng bị bỏ trống
Trả lời
4
Đọc
174
HeSanbi
HeSanbi
GPE-Trợ Lý
KHÓA HỌC BỨT PHÁ KỸ NĂNG EXCEL
    • Thích
    • Yêu thích
Trả lời
2
Đọc
899
nguyentnct
N
N
  • Question Question
Cần giúp rút gọn code vba
Trả lời
8
Đọc
229
VetMini
V
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
13 14 15
Trả lời
299
Đọc
20K
trdethuong
T
D
Vẽ biểu đồ phân tích doanh thu và lợi nhuận theo mã đơn vị
Trả lời
5
Đọc
881
thuytrangbp28
T
HeSanbi
  • Đã giải quyết
VBA Nâng cao: Khi ô Excel ở chế độ đang nhập liệu thì VBA có thể chạy và lấy giá trị ô không?
    • Thích
    • Cảm ơn
Trả lời
9
Đọc
2K
A HOANG 620
A
M
  • Question Question
Code VBA tìm mã kiện gỗ còn tồn kho
Trả lời
5
Đọc
203
moihocvba
M
P
Xin hỏi cách tăng tốc khi nhập liệu cho sheet NHAPXUAT
Trả lời
4
Đọc
205
yeudoi
yeudoi
S
Tính trung bình của tháng đầu tiên.
Trả lời
5
Đọc
293
SteveNguyen1991
S
A
  • Đã giải quyết
Xin giúp đỡ code VBA chép cột dữ liệu có điều kiện từ file này sang file khác
2 3
Trả lời
59
Đọc
3K
Hoàng Nhật Phương
Hoàng Nhật Phương
T
  • Question Question
Xin code VBA trả về tên tài khoản theo điều kiện
    • Chấp nhận
Trả lời
10
Đọc
234
DeTong
D
H
Nhờ các cao nhân chỉ giáo code file Form nhập liệu Google Sheet !!!
    • Thích
Trả lời
4
Đọc
111
befaint
befaint
hoamattroicoi
TỔNG HỢP TỜ KHAI THUẾ THEO THÔNG TƯ 80/2021 TỪ *.XML SANG EXCEL
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
7
Đọc
3K
Nguyễn Văn Thái 92
N
dungdodac
Lỗi khi COPY , viền xung quanh ô được chọn đứng yên, không chạy
    • Cười
Trả lời
4
Đọc
208
VetMini
V
B
Xin hàm đếm số lượng khách hàng theo 1 điều kiện và bỏ dữ liệu trùng.
Trả lời
10
Đọc
392
Phan Thế Hiệp
Phan Thế Hiệp
H
Giao diện mới ở "chế độ tối" mờ quá
    • Yêu thích
    • Thích
Trả lời
4
Đọc
153
OverAC
OverAC
Xem thêm…

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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới
Back
Top Bottom