Sub Fill_data()
Dim wb As Workbook
Dim vbProj As VBIDE.VBProject
Dim vbComp As VBIDE.VBComponent
Dim vbMod As VBIDE.CodeModule
Dim filePath As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
filePath = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")
If filePath = "False" Then Exit Sub
Set wb = Workbooks.Open(filePath)
wb.Activate
Set vbProj = wb.VBProject
Set vbComp = vbProj.VBComponents.Add(vbext_ct_StdModule)
Set vbMod = vbComp.CodeModule
vbMod.InsertLines 1, "Sub CapSo1ChoVungAB()" & vbCrLf & _
" Dim ws As Worksheet" & vbCrLf & _
" Dim i As Long" & vbCrLf & _
" Application.ScreenUpdating = False" & vbCrLf & _
" Application.Calculation = xlCalculationManual" & vbCrLf & _
" For Each ws In ThisWorkbook.Worksheets" & vbCrLf & _
" ws.Range(""AB1:AB220"").ClearContents" & vbCrLf & _
" ws.Range(""AB1:AB220"").MergeCells = False" & vbCrLf & _
" For i = 4 To 200" & vbCrLf & _
" If ws.Cells(i, ""B"").Value <> """" And Not ws.Rows(i).Hidden Then" & vbCrLf & _
" ws.Cells(i, ""AB"").Value = 1" & vbCrLf & _
" End If" & vbCrLf & _
" Next i" & vbCrLf & _
" Next ws" & vbCrLf & _
" Application.ScreenUpdating = True" & vbCrLf & _
" Application.Calculation = xlCalculationAutomatic" & vbCrLf & _
"End Sub"
Set vbComp = vbProj.VBComponents("ThisWorkbook")
Set vbMod = vbComp.CodeModule
vbMod.InsertLines vbMod.CountOfLines + 1, "Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)" & vbCrLf & _
" Call CapSo1ChoVungAB" & vbCrLf & _
"End Sub"
wb.SaveAs Replace(filePath, ".xlsx", ".xlsm"), FileFormat:=52
wb.Close SaveChanges:=True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub