Điều Chỉnh Code Tách File (1 người xem)

[letinnghia]

Chào các anh, chị và các bạn GPE!
Các anh, chị điều chỉnh code giùm mình sao cho các file được tạo ra có đuôi .xlsm, nội dung trong file mới tạo ra được giữ nguyên giống file cũ 100% và chỉ xóa dữ liệu cột CI:CJ.
Mình đã thử sửa code để file mới được tạo ra có đuôi .xlsm nhưng không được nên rất mong nhận được sự giúp đỡ của các anh chị và các bạn.
Trân trọng cảm ơn!

 

[vu_tuan_manh_linh]

Bạn kiểm tra lại đoạn code này xem có gì đó cần chỉnh sửa không nhé!!

 .Close True, ThisWorkbook.Path & "\" & Sa.Offset(, 1).Value & ".xlsx"

 

[letinnghia]

Bạn kiểm tra lại đoạn code này xem có gì đó cần chỉnh sửa không nhé!!

 .Close True, ThisWorkbook.Path & "\" & Sa.Offset(, 1).Value & ".xlsx"

Cảm ơn bạn, trước khi mình gửi bài lên GPE mình cũng có thử sửa code: Close True, ThisWorkbook.Path & "" & Sa.Offset(, 1).Value & ".xlsx" thành Close True, ThisWorkbook.Path & "" & Sa.Offset(, 1).Value & ".xlsm" nhưng không được bạn ơi.
Bạn dành chút ít thời gian chỉnh sủa code giùm mình.
Trân trọng cảm ơn

 

[vu_tuan_manh_linh]

Cảm ơn bạn, trước khi mình gửi bài lên GPE mình cũng có thử sửa code: Close True, ThisWorkbook.Path & "" & Sa.Offset(, 1).Value & ".xlsx" thành Close True, ThisWorkbook.Path & "" & Sa.Offset(, 1).Value & ".xlsm" nhưng không được bạn ơi.
Bạn dành chút ít thời gian chỉnh sủa code giùm mình.
Trân trọng cảm ơn

File của bạn đây!!
1. Đặt 1 biến gán cho nó giá trị đường dẫn file hiện hành
2. Trong quá trình sao chép dữ liệu, cần phân biệt workbook hiện hành để thực thi lệnh save

 

[letinnghia]

File của bạn đây!!
1. Đặt 1 biến gán cho nó giá trị đường dẫn file hiện hành
2. Trong quá trình sao chép dữ liệu, cần phân biệt workbook hiện hành để thực thi lệnh save

Cảm ơn bán!
1. Đặt một biến gán cho nó giá trị.........
2. Trong quá trình sao chép dữ liệu........
Bạn có thể chỉ rỏ hơn cho mình. mình chưa hiểu chổ này và không biết thực hiện như thế nào.
Bạn chỉnh code sao cho:
1. File mới tạo được ra có tất cả các code như file gốc
2. Dữ liệu trong file mới được tạo ra không bị xóa dữ liệu mà giống file cũ hoàn toàn(code hiện tại bị xóa hết còn có 1 dòng thôi)
3. Dữ liệu trong file mới xóa bớt cột CI:CJ
Kết luận: Mình mong muốn file mới được tạo ra giống như chúng ta thực hiện copy và paste file vậy.
Làm phiền bạn quá nhưng vì mình không rành code nên rất mong bạn giúp đỡ.
Trân trọng cảm ơn

 

[vu_tuan_manh_linh]

Cảm ơn bán!
1. Đặt một biến gán cho nó giá trị.........
2. Trong quá trình sao chép dữ liệu........
Bạn có thể chỉ rỏ hơn cho mình. mình chưa hiểu chổ này và không biết thực hiện như thế nào.
Bạn chỉnh code sao cho:
1. File mới tạo được ra có tất cả các code như file gốc
2. Dữ liệu trong file mới được tạo ra không bị xóa dữ liệu mà giống file cũ hoàn toàn(code hiện tại bị xóa hết còn có 1 dòng thôi)
3. Dữ liệu trong file mới xóa bớt cột CI:CJ
Kết luận: Mình mong muốn file mới được tạo ra giống như chúng ta thực hiện copy và paste file vậy.
Làm phiền bạn quá nhưng vì mình không rành code nên rất mong bạn giúp đỡ.
Trân trọng cảm ơn

Bạn tải file về xem nó thế nào đã rồi hãy nói tiếp nhé!

 

[letinnghia]

Nhìn code quen quá...Hình như là code tôi viết trước kia. Vậy bạn lấy lại code này, cải tiến hơn code trước (nhanh hơn, đơn giản hơn ) cho file của bạn.

Public Sub GPE()
Dim Dic As Object, Tmp As String, Arr, Pth, ShMain As Worksheet
Dim I As Long, K As Long, WbMain As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set WbMain = ThisWorkbook
Set ShMain = WbMain.Sheets("Sheet1")
Pth = ActiveWorkbook.Path
Arr = ShMain.Range("CI2", ShMain.Range("CI65000").End(3)).Resize(, 2).Value
Set Dic = CreateObject("Scripting.Dictionary")
With Dic
For I = 1 To UBound(Arr, 1)
Tmp = Arr(I, 1) & "-" & Arr(I, 2)
    If Not .Exists(Tmp) Then
        K = K + 1
        .Add Tmp, K
    Set Rng = ShMain.Range("A1", ShMain.Range("A65000").End(3)).Resize(, 88)
        With Workbooks.Add
            Set Sh = .Sheets(1)
            Rng.AutoFilter 87, Arr(I, 1)
            ShMain.Range(ShMain.Range("A1"), Rng).SpecialCells(12).Copy
            Sh.Range("A1").PasteSpecial xlPasteAll
            Sh.Range("CI:CJ").EntireColumn.Delete
            Rng.AutoFilter
            ActiveWorkbook.SaveAs Pth & "\" & Arr(I, 2) & ".xlsm", xlOpenXMLWorkbookMacroEnabled
            ActiveWorkbook.Close True
        End With
    End If
Next I
End With
ShMain.AutoFilterMode = False
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Cảm ơn hpkhuong,
Bạn giúp mình thêm code tách file này, tên file cần tách ở cột Z
File mới được tạo ra có đầy đủ code như file hiện tại, dữ liệu cột Z được xóa đi
Cảm ơn hpkhuong nhé.

 

[letinnghia]

Tôi chưa hiểu í bạn... File mới tạo ra chứa đầy đủ code là sao? code ở đây là các Sub của bạn trong file ấy hả? hay là sao.

1. Nếu vậy thì bạn tự copy file và đổi tên theo mong muốn...chứ code két gì ở đây??? Vì mỗi file khi mở lên chỉ được Save chính nó hoặc là SaveAs sang 1 định dạng khác/ hoặc tên khác cũng chỉ được 1 file (1 lần)...chứ làm sao mà theo danh sách được...

2. Trừ phi ý của bạn là chỉ copy cái sheet1 của file hiện tại và lưu thành từng file theo danh sách cột Z thì được.... Cái này thì chỉ lưu mỗi mẫu sheet1 đó thôi... Code VBA trên file mới này sẽ không còn...

------------------
Còn nếu là ý của bạn là theo ý 1. ở trên tôi nói, mà vẫn muốn dùng code để copy thì bạn phản hồi nhé,...hoặc là theo ý 2 cũng phản hồi...để biết mà code cho phù hợp.

------------------

Cảm ơn thì có nút cảm ơn ở trên đó bạn!

Thế nhé!

Cảm ơn bạn,
Ý mình là file mới được tạo giống như chúng ta copy file và Paste và sửa tên file vậy đó hoặc Save As file gốc ra nhiều file.
Code mà mình muốn nói ở đây là code trong sub hoặc trong Modules.
Cảm ơn bạn.

 

[letinnghia]

Public Sub GPE()
Dim Arr, I As Long, Path As String, PathFull As String, fMainN As String
Dim Fso As Object, Fil As Object, ChonFil As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Path = ThisWorkbook.Path: PathFull = ThisWorkbook.FullName: fMainN = ThisWorkbook.Name
Arr = Range("Z3", Range("Z3").End(4)).Value
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For I = 1 To UBound(Arr)
    Fso.CopyFile PathFull, Path & "\" & Arr(I, 1) & ".xlsm"
Next I
Set ChonFil = Fso.GetFolder(Path)
On Error Resume Next
For Each Fil In ChonFil.Files
    If InStr(1, Fil.Name, fMainN) < 1 Then
        With Workbooks.Open(Fil.Path)
            .Sheets("Sheet1").Unprotect "aaa"
            .Sheets("Sheet1").Range("Z:Z").EntireColumn.Delete
            .Sheets("Sheet1").Protect "aaa"
            .Close True
        End With
    End If
Next Fil
MsgBox "Da Tach Xong!"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Cảm ơn bạn,
Code thật tuyệt vời,
Mình có 1 việc mong tiếp tục nhận được sự giúp đỡ của bạn nhưng không biết có thực hiện được hay không bạn nghiêng cứu giúp mình với.
Lấy tên file điền vào cell B5:B6, nếu giải quyết được chổ này thì không còn gì tuyệt vời hơn.
Một lần nữa Trân Trọng Cảm Ơn Bạn Rất Nhiều

 

[letinnghia]

Public Sub GPE()
Dim Arr, I As Long, Path As String, PathFull As String, fMainN As String
Dim Fso As Object, Fil As Object, ChonFil As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Path = ThisWorkbook.Path: PathFull = ThisWorkbook.FullName: fMainN = ThisWorkbook.Name
Arr = Range("Z3", Range("Z3").End(4)).Value
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For I = 1 To UBound(Arr)
    Fso.CopyFile PathFull, Path & "\" & Arr(I, 1) & ".xlsm"
Next I
Set ChonFil = Fso.GetFolder(Path)
On Error Resume Next
For Each Fil In ChonFil.Files
    If InStr(1, Fil.Name, fMainN) < 1 Then
        With Workbooks.Open(Fil.Path)
            .Sheets("Sheet1").Unprotect "aaa"
            .Sheets("Sheet1").Range("B5").Value = Fso.GetBaseName(Fil)
            .Sheets("Sheet1").Range("Z:Z").EntireColumn.Delete
            .Sheets("Sheet1").Protect "aaa"
            .Close True
        End With
    End If
Next Fil
MsgBox "Da Tach Xong!"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Cảm ơn sự nhiệt tình giúp đỡ của bạn.
Code chạy rất ổn hpkhuong à.
Một lần nữa Trân Trọng Cảm Ơn Bạn!