Chèn 1 đoạn Code vào module của tất cả các file có cùng tên nằm trong nhiều thư mục con

Liên hệ QC
T

thesaintzero

Thành viên hoạt động
Tham gia
16/3/09
Bài viết
156
Được thích
7
Chào các bác, chúc các bác một ngày vui vẻ.
Chẳng là mình đang làm tổng hợp nhiều file cho các đơn vị
Mình muốn tìm tất cả các file trong 1 thư mục (bao gồm cả thư mục con) có cùng 1 tên (ví dụ: Kiem_tra_hang.xls)
sau đó mình có 1 đoạn code do mình viết muốn chèn vào tất cả các module của các file "Kiem_tra_hang.xls" (module có sẵn trong các file)
Sheets("Sheet1").Select
Range("Q10").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-7]="""","""",(RC[-1]-((RC[9]*RC[5])/100)*RC[8])/RC[-7])"
Range("Q10").Select
Selection.AutoFill Destination:=Range("Q10:Q200"), Type:=xlFillDefault
Range("Q10:Q200").Select
Selection.NumberFormat = "0.00"
Mong các bác giúp mình, mình kiếm trên diễn đàn chưa thấy ai hỏi như thế này bao giờ nên mạo muội viết bài để mong các giúp đỡ.
(do các file được gửi là file mật nên mình không up lên được, mong các bác thông cảm)
 
thesaintzero đã viết:
Chào các bác, chúc các bác một ngày vui vẻ.
Chẳng là mình đang làm tổng hợp nhiều file cho các đơn vị
Mình muốn tìm tất cả các file trong 1 thư mục (bao gồm cả thư mục con) có cùng 1 tên (ví dụ: Kiem_tra_hang.xls)
sau đó mình có 1 đoạn code do mình viết muốn chèn vào tất cả các module của các file "Kiem_tra_hang.xls" (module có sẵn trong các file)
Sheets("Sheet1").Select
Range("Q10").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-7]="""","""",(RC[-1]-((RC[9]*RC[5])/100)*RC[8])/RC[-7])"
Range("Q10").Select
Selection.AutoFill Destination:=Range("Q10:Q200"), Type:=xlFillDefault
Range("Q10:Q200").Select
Selection.NumberFormat = "0.00"
Mong các bác giúp mình, mình kiếm trên diễn đàn chưa thấy ai hỏi như thế này bao giờ nên mạo muội viết bài để mong các giúp đỡ.
(do các file được gửi là file mật nên mình không up lên được, mong các bác thông cảm)
Nhấp chuột vào đây để mở rộng...
Cho cái đoạn code này vào add-in mà dùng cho nhiều file có vẻ hợp lý.
 
snow25 đã viết:
Cho cái đoạn code này vào add-in mà dùng cho nhiều file có vẻ hợp lý.
Nhấp chuột vào đây để mở rộng...
ah! ý bạn nói là addin trong file chính của mình ấy hả?
Không tại đây là công thức mình muốn chèn vào 1 cột của tất cả các file, khi trả lại cho các đơn vị thì nó tự chạy ra số liệu, còn cái bạn nói là mình phải mở từng file rồi click vào từng file.
 
Mình có lấy code của bác Ndu và viết thêm vào một số nội dung mà sao nó không chạy? các bác xem giúp nó bị lỗi chỗ nào mà nó không chạy.
Ở đây mình lấy code của bác Ndu chèn ""dữ liệu"" vào module, ý tưởng của mình là tìm từng file trong thư mục, bao gồm cả thư mục con, mở từng file lên, chèn đoạn code vào module và đóng file lại. Mong các bác góp ý giúp em!

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()
On Error Resume Next
Dim strCode As String, bChk As Boolean, fpath As String, ftype As String, i As Integer
strCode = "Sub chen()" & vbLf & _
"Sheets("Sheet1").Select" & vbLf & _
"Range("Q10").Select" & vbLf & _
"ActiveCell.FormulaR1C1 = "=IF(RC[-7]="""","""",(RC[-1]-((RC[9]*RC[5])/100)*RC[8])/RC[-7])" & vbLf & _
"Range("Q10").Select" & vbLf & _
"Selection.AutoFill Destination:=Range("Q10:Q200"), Type:=xlFillDefault" & vbLf & _
"Range("Q10:Q200").Select" & vbLf & _
"election.NumberFormat = "0.00" & vbLf & _
"End Sub"
fpath = "C:\Users\Desktop\New folder (2)"
ftype = "*.xls"
With Application.FileSearch
.NewSearch
.LookIn = fpath
.SearchSubFolders = True
.Filename = ftype
Set template = .Documents.Open(ThisWorkbook.Path)
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
bChk = IsVBATrusted
If bChk = False Then ChangeVBOM
bChk = IsVBATrusted
If bChk Then
With ActiveWorkbook.VBProject.VBComponents("Thisworkbook").CodeModule
.DeleteLines 1, .CountOfLines
On Error GoTo 0
.AddFromString (strCode)
End With
End If
Next i
End If
template.Close
End With
End Sub
 
Bạn tạo một file mới copy code dưới vào module, đổi đường dẫn đến thư mục
trước hết bạn thử sub Chen bên dưới test xem đúng hay chưa.
Cuối cùng là chạy test_ChenCode

PHP: 
Option Explicit
Sub test_ChenCode()
On Error Resume Next
    ' Add Scripting Runtime'
 ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\system32\scrrun.dll"
 Application.Volatile
On Error Goto 0

  Dim Path$, sFolder, FSO As New Scripting.FileSystemObject
  Path = ThisWorkbook.Path 'Thay đổi đường dẫn thành C:\. ...'
  If Not FSO.FolderExists(Path) Then Exit Sub
  Set sFolder = FSO.GetFolder(Path)
  ChenCode sFolder, True
  Set sFolder = Nothing
  Set FSO = Nothing
End Sub

Sub Chen()
  With ThisWorkbook.Worksheets("Sheet1")
    .Range("Q10").FormulaR1C1 = "=IF(RC[-7]="""","""",(RC[-1]-((RC[9]*RC[5])/100)*RC[8])/RC[-7])"
    .Range("Q10").AutoFill Destination:=.Range("Q10:Q200"), Type:=xlFillDefault
    .Range("Q10:Q200").NumberFormat = "0.00"
  End With
End Sub

Public Sub ChenCode(ByVal sFolder As Scripting.Folder, iSubfolders As Boolean)

  Call IsVBATrusted

  Dim Item, SubFolder, VBComp As Object, tmp$, ProcName$
  ProcName = "Chen"
  Const file = "Kiem_tra_hang.xls"
  For Each Item In sFolder.Files
    If LCase$(Item.Path) Like LCase$("*\" & file) Then '"&
      tmp = file: Workbooks.Open Item.Path
      Exit For
    End If
  Next
  Set Item = Nothing

If tmp <> vbNullString Then
    If GetProcCode(ProcName, Workbooks(tmp)) = vbNullString Then
    With Workbooks(tmp)
      For Each VBComp In .VBProject.VBComponents
        If VBComp.Type = 1 Then GoSub AddCode: Exit For
        Set VBComp = Nothing
      Next
      If VBComp Is Nothing Then
        Set VBComp = .VBProject.VBComponents.Add(1)
        GoSub AddCode: Set VBComp = Nothing
      End If
      Application.DisplayAlerts = False
      .Close True
      Application.DisplayAlerts = True
    End With
  End If:End If
  On Error GoTo 0
  If iSubfolders Then
    For Each SubFolder In sFolder.SubFolders
      ChenCode SubFolder, True
    Next
    Set SubFolder = Nothing
  End If
  Exit Sub
AddCode:
  With VBComp.CodeModule
    tmp = GetProcCode(ProcName)
    If .CountOfLines <= 0 Then
      .AddFromString tmp
    Else
      .InsertLines .CountOfLines, tmp
    End If
  End With
Return
End Sub
Function GetProcCode(ProcName$, Optional ByVal WB As Workbook) As String
    If WB Is Nothing Then Set WB = ThisWorkbook
    Dim Line&
    If ProcName = vbNullString Then Exit Function
    With WB
      Dim VBComp
      For Each VBComp In .VBProject.VBComponents
        If VBComp.Type = 1 Then
          With VBComp.CodeModule
            On Error Resume Next
            Line = .ProcStartLine(ProcName, 0)
            If Err.Number = 0 Then
              GetProcCode = .Lines(.ProcStartLine(ProcName, 0), .ProcCountLines(ProcName, 0))
              Set VBComp = Nothing
              Exit For
            End If
            Err.Clear
    End With: End If: Next: End With
  End Function
Function IsVBATrusted() As Boolean
  On Error Resume Next
  IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing
  If Err.Number <> 0 Then
    CreateObject("WScript.Shell").RegWrite _
        "HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" _
        & Application.Version & "\Excel\Security\AccessVBOM", 1, "REG_DWORD"
    Application.Volatile
    IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing
  End If
End Function
 
Lần chỉnh sửa cuối:
HeSanbi đã viết:
Bạn tạo một file mới copy code dưới vào module, đổi đường dẫn đến thư mục
trước hết bạn thử sub Chen bên dưới test xem đúng hay chưa.
Cuối cùng là chạy test_ChenCode

PHP: 
Option Explicit
Sub test_ChenCode()
  Dim Path$, sFolder, FSO As New Scripting.FileSystemObject
  Path = ThisWorkbook.Path 'Dien duong dan vào day'
  If Not FSO.FolderExists(Path) Then Exit Sub
  Set sFolder = FSO.GetFolder(Path)
  ChenCode sFolder, True
  Set sFolder = Nothing
  Set FSO = Nothing
End Sub

Sub Chen()
  With ThisWorkbook.Worksheets("Sheet1")
    .Range("Q10").FormulaR1C1 = "=IF(RC[-7]="""","""",(RC[-1]-((RC[9]*RC[5])/100)*RC[8])/RC[-7])"
    .Range("Q10").AutoFill Destination:=.Range("Q10:Q200"), Type:=xlFillDefault
    .Range("Q10:Q200").NumberFormat = "0.00"
  End With
End Sub

Public Sub ChenCode(ByVal sFolder As Scripting.Folder, iSubfolders As Boolean)

  Call IsVBATrusted

  Dim Item, SubFolder, VBComp As Object, tmp$, ProcName$
  ProcName = "Chen"
  Const file = "Kiem_tra_hang.xls"
  For Each Item In sFolder.Files
    If LCase$(Item.Path) Like LCase$("*\" & file) Then '"&
      tmp = file: Workbooks.Open Item.Path
      Exit For
    End If
  Next
  Set Item = Nothing
  If tmp <> vbNullString And _
  GetProcCode(ProcName, Workbooks(tmp)) = vbNullString Then
    With Workbooks(tmp)
      For Each VBComp In .VBProject.VBComponents
        If VBComp.Type = 1 Then GoSub AddCode: Exit For
        Set VBComp = Nothing
      Next
      If VBComp Is Nothing Then
        Set VBComp = .VBProject.VBComponents.Add(1)
        GoSub AddCode: Set VBComp = Nothing
      End If
      Application.DisplayAlerts = False
      .Close True
      Application.DisplayAlerts = True
    End With
  End If
  On Error GoTo 0
  If iSubfolders Then
    For Each SubFolder In sFolder.SubFolders
      ChenCode SubFolder, True
    Next
    Set SubFolder = Nothing
  End If
  Exit Sub
AddCode:
  With VBComp.CodeModule
    tmp = GetProcCode(ProcName)
    If .CountOfLines <= 0 Then
      .AddFromString tmp
    Else
      .InsertLines .CountOfLines, tmp
    End If
  End With
Return
End Sub
Function GetProcCode(ProcName$, Optional ByVal WB As Workbook) As String
    If WB Is Nothing Then Set WB = ThisWorkbook
    Dim Line&
    If ProcName = vbNullString Then Exit Function
    With WB
      Dim VBComp
      For Each VBComp In .VBProject.VBComponents
        If VBComp.Type = 1 Then
          With VBComp.CodeModule
            On Error Resume Next
            Line = .ProcStartLine(ProcName, 0)
            If Err.Number = 0 Then
              GetProcCode = .Lines(.ProcStartLine(ProcName, 0), .ProcCountLines(ProcName, 0))
              Set VBComp = Nothing
              Exit For
            End If
            Err.Clear
    End With: End If: Next: End With
  End Function
Function IsVBATrusted() As Boolean
  On Error Resume Next
  IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing
  If Err.Number <> 0 Then
    CreateObject("WScript.Shell").RegWrite _
        "HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" _
        & Application.Version & "\Excel\Security\AccessVBOM", 1, "REG_DWORD"
    Application.Volatile
    IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing
  End If
End Function
Nhấp chuột vào đây để mở rộng...
Cám ơn bác HesanBi quan tâm, chiều giờ bận quá, giờ em mới on được. Nó bị lỗi ngay tại vị trí này nè bác
Public Sub ChenCode(ByVal sFolder As Scripting.Folder, iSubfolders As Boolean)
Bác có thể kiểm tra lại giúp em được không?
 
thesaintzero đã viết:
Cám ơn bác HesanBi quan tâm, chiều giờ bận quá, giờ em mới on được. Nó bị lỗi ngay tại vị trí này nè bác
Public Sub ChenCode(ByVal sFolder As Scripting.Folder, iSubfolders As Boolean)
Bác có thể kiểm tra lại giúp em được không?
Nhấp chuột vào đây để mở rộng...
Bạn vào tools, vào references, thêm Microsoft Scripting Runtime vô
 
Bác HeSanbi em làm theo hướng dẫn của bác, nhưng sao nó vẫn báo lỗi như hình nè bác, bác xem giúp em không biết có sai chỗ nào không? với lại cho em hỏi:
For Each Item In sFolder.Files
If LCase$(Item.Path) Like LCase$("*\" & file) Then '"& cái chỗ này đâu có thêm gì đâu bác nhỉ
 

File đính kèm

  • Untitled.png
    Untitled.png
    82.5 KB · Đọc: 13
Lần chỉnh sửa cuối:
thesaintzero đã viết:
Bác HeSanbi em làm theo hướng dẫn của bác, nhưng sao nó vẫn báo lỗi như hình nè bác, bác xem giúp em không biết có sai chỗ nào không? với lại cho em hỏi:
For Each Item In sFolder.Files
If LCase$(Item.Path) Like LCase$("*\" & file) Then '"& cái chỗ này đâu có thêm gì đâu bác nhỉ
Nhấp chuột vào đây để mở rộng...
Thử
ByVal sFolder As Object
 
thesaintzero đã viết:
Giờ nó tới lỗi này bác HeSanbi ơi! không biết tại sao nữa!
Nhấp chuột vào đây để mở rộng...
Bạn vào tools, vào references, thêm Microsoft Scripting Runtime vô

Không thì copy hàng dưới vào trên dòng đó:

PHP: 
On Error Resume Next
    ' Add Scripting Runtime'
 ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\system32\scrrun.dll"
 Application.Volatile
On Error Goto 0
 
HeSanbi đã viết:
Bạn vào tools, vào references, thêm Microsoft Scripting Runtime vô

Không thì copy hàng dưới vào trên dòng đó:

PHP: 
On Error Resume Next
    ' Add Scripting Runtime'
ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\system32\scrrun.dll"
Application.Volatile
On Error Goto 0
Nhấp chuột vào đây để mở rộng...
Sau khi sửa theo Bác, em bấm chạy thì không thấy báo lỗi nữa nhưng hình như code không chịu chạy vì trong file Kiem_tra_hang.xls không có file module tạo ra. Bác HeSanbi giúp em chỗ này đi. Em gửi hình cho bác xem.
 

File đính kèm

  • Untitled.png
    Untitled.png
    72.9 KB · Đọc: 9
Bạn điền Path bị sai, thì sao Code chạy được, bạn ngâm sao cho đúng là nó chạy, tôi không hỗ trợ bạn nữa nhé.

Ở trên có nói rõ là copy vào trên dòng bị lỗi, nhìn lại thì thấy nó nằm dưới. Trợ giúp cũng khó lắm
 
Lần chỉnh sửa cuối:
HeSanbi đã viết:
Bạn điền Path bị sai, thì sao Code chạy được, bạn ngâm sao cho đúng là nó chạy, tôi không hỗ trợ bạn nữa nhé.

Ở trên có nói rõ là copy vào trên dòng bị lỗi, nhìn lại thì thấy nó nằm dưới. Trợ giúp cũng khó lắm
Nhấp chuột vào đây để mở rộng...
oh! em nhầm, nhưng vẫn không được bác ah! em không biết đường dẫn bị sai chỗ nào.
Em đọc lại code bác viết có mấy chỗ không hiểu bác giải thích hộ em với
Dim Path$, sFolder, FSO As New Scripting.FileSystemObject
Path = ThisWorkbook.Path 'Dien duong dan vào day'
If Not FSO.FolderExists(Path) Then Exit Sub
Set sFolder = FSO.GetFolder(Path)
ChenCode sFolder, True
Set sFolder = Nothing
Set FSO = Nothing
End Sub
Em thấy bác đặt Path$ nhưng không thấy dữ liệu nào được đưa vào Path$ này.
Dim Line&
If ProcName = vbNullString Then Exit Function
Đây nữa nè bác.
Em thật sự không biết mong bác chỉ giáo cho!:(
 
Đổi: Path = ThisWorkbook.Path
Thành: Path = "C:\...."
 
Em cám ơn bác HeSanbi rất nhiều, em làm được rồi, em phải check rất nhiều thứ trong referent để nó chạy, check cả vào trust VBA for Excel ....@@, Do em kiểm tra trên máy tính của cơ quan nên nó thiếu rất nhiều cấu trúc, mong bác thông cảm. Thật sự thì khi nhìn nó chạy em rất vui, em cám ơn bác rất nhiều.
 
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

maytinhvp01
  • Question
Chuyên đề giải đáp những thắc mắc về code VBA
    • Thích
151 152 153
Trả lời
3K
Đọc
275K
VetMini
V
hongquan93vn
Tìm công thức có thể đánh STT của giá trị mỗi lần xuất hiện
2
Trả lời
22
Đọc
216
VetMini
V
Justine Miller
em cần sự trợ giúp
Trả lời
3
Đọc
50
CHAOQUAY
C
8
  • Question
Xin giúp: Nhóm (group data) các dòng trong bảng tính
Trả lời
11
Đọc
408
forcebk
F
hung2412
  • Question
Có Code VBA nào để tự động điều chỉnh tỷ lệ hiển thị màn hình theo thông số Recommended (Theo từng Laptop, PC)?
Trả lời
5
Đọc
134
befaint
befaint
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