Thêm 1 sheet mẫu mới vào nhiều file excel giống nhau

Hoang Manh Thang · 18/1/19

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 đỡ ạ.

be_09 · 18/1/19

Hoang Manh Thang đã viết:
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ọ.

Hoang Manh Thang · 18/1/19

be09 đã viết:
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 ạ:

echo07 · 18/1/19

Copy sheet cũng được mà, bạn làm 63 lần thôi, chắc đâu đó tầm 10 phút là xong.

Hoang Manh Thang · 18/1/19

echo07 đã viết:
Copy sheet cũng được mà, bạn làm 63 lần thôi, chắc đâu đó tầm 10 phút là xong.

Uhm, nhưng mà sau này nhỡ phải làm nhiều hơn nữa thì cũng mất thời gian mà. Nên mình cũng muốn học thêm.

HeSanbi · 20/1/19

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

Hoang Manh Thang · 21/1/19

HeSanbi đã viết:

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

Em cám ơn bác nhé ạ

Thêm 1 sheet mẫu mới vào nhiều file excel giống nhau

Hoang Manh Thang

Thành viên mới

File đính kèm

be_09

Biên Hòa, Đồng Nai

Hoang Manh Thang

Thành viên mới

File đính kèm

echo07

Nguyệt Hà

Hoang Manh Thang

Thành viên mới

HeSanbi

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨

Hoang Manh Thang

Thành viên mới

Bài viết mới nhất

Facebook

Group

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