Dear các anh chị,
Hiện em đang có 1 folder excel chứa 63 file tỉnh thành phố.
Ở mỗi file excel đó, em muốn thêm vào 1 sheet mẫu mới. Sheet đó được lưu tại file excel book1.xlsx ạ. Em xin tải lên 2 file mẫu ạ.
Mong các anh, chị giúp em xem có cách nào nhanh chóng để add được sheet vào từng file không ạ? Em có tìm hiểu qua về macro nhưng trình độ còn kém nên mong mọi người giúp đỡ ạ.
Dear các anh chị,
Hiện em đang có 1 folder excel chứa 63 file tỉnh thành phố.
Ở mỗi file excel đó, em muốn thêm vào 1 sheet mẫu mới. Sheet đó được lưu tại file excel book1.xlsx ạ. Em xin tải lên 2 file mẫu ạ.
Mong các anh, chị giúp em xem có cách nào nhanh chóng để add được sheet vào từng file không ạ? Em có tìm hiểu qua về macro nhưng trình độ còn kém nên mong mọi người giúp đỡ ạ.
Góp ý cho bạn:
1/ Bạn giải thích chẳng có rỏ ràng gì cả, phải cụ thể File 63 file tỉnh là của các tỉnh gửi cho bạn hay bạn gửi cho họ.
2/ Bạn Phải đưa cái File mẫu của 1 tỉnh gửi cho bạn hoặc File mẫu bạn gửi cho họ.
Góp ý cho bạn:
1/ Bạn giải thích chẳng có rỏ ràng gì cả, phải cụ thể File 63 file tỉnh là của các tỉnh gửi cho bạn hay bạn gửi cho họ.
2/ Bạn Phải đưa cái File mẫu của 1 tỉnh gửi cho bạn hoặc File mẫu bạn gửi cho họ.
Dạ,
Cơ bản là em nhận được 63 file tỉnh, khá nặng nên em không tải hết lên ạ. File 11.xlsx là 1 trong 63 file đó.
Giờ em cần add thêm sheet Introduction trong file Book1.xlsx vào file 11.xlsx ạ. Làm lần lượt cho 63 tỉnh và sau đó có thể số lượng sẽ nhiều hơn.
Kết quả đầu ra, em cần là 1 file giống như sau ạ:
Tôi có code dưới đây. Tuy nhiên có nhiều cách copy tôi đề xuất trong code.
Các cách:
1. Copy cả Sheet. Sẽ gặp vấn đề nếu Workbook ở chế độ tương thích.
Nếu chắc chắn các workbook không ở chế độ này thì nên dùng.
2. Copy [A1:AZ1000] - Có thể thay đổi . ở chế độ tương thích vẫn copy được
Bạn có thể chọn cách phù hợp.
Copy code dưới vào module của book1.xlsx và save file .xlsm hoặc .xlsb
chạy Sub RunProgramsAddSheetToWorkbook
book1.xlsx và 63 file đặt chung một folder.
Khi chạy nếu đặt là True thì cho phép copy vào cả các Workbook đang mở.
PHP:
Option Explicit
Sub RunProgramsAddSheetToWorkbook()
AddSheetToWorkbook False 'True - For Workbook Running
End Sub
Public Sub AddSheetToWorkbook(Optional ByVal AddWBisOpen As Boolean = False)
Dim EnableEdit&
EnableEdit& = Application.AutomationSecurity
Application.CutCopyMode = True
Application.AutomationSecurity = msoAutomationSecurityLow
Dim FileArray As Variant, sPath$, sh As Object, shs As Object, _
HasSheet As Boolean, Obj As Workbook, IsReadOnly As Boolean, Fso As Object, _
FileItem As Object
On Error Resume Next
ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\system32\scrrun.dll"
On Error GoTo 0
Set Fso = CreateObject("Scripting.FileSystemObject")
Set sh = ThisWorkbook.Worksheets(1)
sh.Parent.VBProject.VBComponents(sh.CodeName) _
.Properties("_CodeName") = "NewComp" & sh.Name
sPath$ = ThisWorkbook.Path
For Each FileItem In Fso.GetFolder(sPath$).Files
If FileItem.Type Like "Microsoft Excel Worksheet" Or FileItem.Type Like "XLS*File" Then
If FileItem.Name <> ThisWorkbook.Name And Left(FileItem.Name, 1) <> "~" Then
On Error Resume Next
Set Obj = Workbooks(FileItem.Name)
If Err.Number <> 0 Then
Set Obj = Workbooks.Open(FileItem.Path, False, False)
If Obj.ReadOnly Then Set Obj = Nothing
Else
If Obj.ReadOnly Then
If AddWBisOpen Then
Obj.Close
Set Obj = Workbooks.Open(FileItem.Path, False, False)
Else
Set Obj = Nothing
End If
Else
If Not AddWBisOpen Then Set Obj = Nothing
End If
End If
On Error GoTo 0
If Not Obj Is Nothing Then
With Obj
For Each shs In .Worksheets
If shs.Name = sh.Name Then HasSheet = True: Exit For
Next shs
If Not HasSheet Then
'Neu là chê' do. Compatibility Mode thì:
'If .CheckCompatibility Then
.CheckCompatibility = False
With .Sheets.Add(Before:=Worksheets(1))
Application.CutCopyMode = True
sh.[A1:AZ1000].Copy .[A1:AZ1000]
'.[A1:Z1000].Value = sh.[A1:Z1000].Value
Application.CutCopyMode = False
.Name = sh.Name
.Parent.VBProject.VBComponents(.CodeName) _
.Properties("_CodeName") = "NewComp" & sh.Name
End With
'Else
'sh.Copy Before:=.Sheets(1)
'.VBProject.VBComponents(sh.CodeName) _
.Properties("_CodeName") = "NewComp" & sh.Name
'End If
End If
.Close True: HasSheet = False
End With
End If
End If
End If
Next FileItem
Set FileItem = Nothing: Set Fso = Nothing
Application.AutomationSecurity = EnableEdit&
Application.CutCopyMode = True
End Sub
Tôi có code dưới đây. Tuy nhiên có nhiều cách copy tôi đề xuất trong code.
Các cách:
1. Copy cả Sheet. Sẽ gặp vấn đề nếu Workbook ở chế độ tương thích.
Nếu chắc chắn các workbook không ở chế độ này thì nên dùng.
2. Copy [A1:AZ1000] - Có thể thay đổi . ở chế độ tương thích vẫn copy được
Bạn có thể chọn cách phù hợp.
Copy code dưới vào module của book1.xlsx và save file .xlsm hoặc .xlsb
chạy Sub RunProgramsAddSheetToWorkbook
book1.xlsx và 63 file đặt chung một folder.
Khi chạy nếu đặt là True thì cho phép copy vào cả các Workbook đang mở.
PHP:
Sub RunProgramsAddSheetToWorkbook()
AddSheetToWorkbook False 'True - For Workbook Running
End Sub
Public Sub AddSheetToWorkbook(Optional ByVal AddWBisOpen As Boolean = False)
Dim EnableEdit&
EnableEdit& = Application.AutomationSecurity
Application.CutCopyMode = True
Application.AutomationSecurity = msoAutomationSecurityLow
Dim FileArray As Variant, sPath$, sh As Object, shs As Object, _
HasSheet As Boolean, Obj As Workbook, IsReadOnly As Boolean
On Error Resume Next
ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\system32\scrrun.dll"
On Error GoTo 0
Set Fso = CreateObject("Scripting.FileSystemObject")
Set sh = ThisWorkbook.Worksheets(1)
sh.Parent.VBProject.VBComponents(sh.CodeName) _
.Properties("_CodeName") = "NewComp" & sh.Name
sPath$ = ThisWorkbook.Path
For Each FileItem In Fso.GetFolder(sPath$).Files
If FileItem.Type Like "Microsoft Excel Worksheet" Or FileItem.Type Like "XLS*File" Then
If FileItem.Name <> ThisWorkbook.Name And Left(FileItem.Name, 1) <> "~" Then
On Error Resume Next
Set Obj = Workbooks(FileItem.Name)
If Err.Number <> 0 Then
Set Obj = Workbooks.Open(FileItem.Path, False, False)
If Obj.ReadOnly Then Set Obj = Nothing
Else
If Obj.ReadOnly Then
If AddWBisOpen Then
Obj.Close
Set Obj = Workbooks.Open(FileItem.Path, False, False)
Else
Set Obj = Nothing
End If
Else
If Not AddWBisOpen Then Set Obj = Nothing
End If
End If
On Error GoTo 0
If Not Obj Is Nothing Then
With Obj
For Each shs In .Worksheets
If shs.Name = sh.Name Then HasSheet = True: Exit For
Next shs
If Not HasSheet Then
'Neu là chê' do. Compatibility Mode thì:
'If .CheckCompatibility Then
.CheckCompatibility = False
With .Sheets.Add(Before:=Worksheets(1))
Application.CutCopyMode = True
sh.[A1:AZ1000].Copy .[A1:AZ1000]
'.[A1:Z1000].Value = sh.[A1:Z1000].Value
Application.CutCopyMode = False
.Name = sh.Name
.Parent.VBProject.VBComponents(.CodeName) _
.Properties("_CodeName") = "NewComp" & sh.Name
End With
'Else
'sh.Copy Before:=.Sheets(1)
'.VBProject.VBComponents(sh.CodeName) _
.Properties("_CodeName") = "NewComp" & sh.Name
'End If
End If
.Close True:HasSheet = False
End With
End If
End If
End If
Next FileItem
Set FileItem = Nothing: Set Fso = Nothing
Application.AutomationSecurity = EnableEdit&
Application.CutCopyMode = True
End Sub