Copy sheet qua file mới bằng VBA

[tranphuson]

Vui lòng giúp mình copy từng Sheet (được đánh dấu X cột cần copy ) qua 1 file mới

Ví dụ: File đính kèm có 03 Sheets "001, 002, 003" thì sẽ được copy ra 03 file tên tương ứng "File 001.xls, File 002.xls, File 003.xls"

Cảm ơn

 

[tranphuson]

Chạy code sau:

Public Sub GPE()
Dim Ws As Worksheet, Cll As Range, Rng As Range, Path
Path = ThisWorkbook.Path
Application.ScreenUpdating = False
Application.SheetsInNewWorkbook = 1
For Each Ws In Worksheets
Ws.Cells(1, 1).Resize(, Columns.Count).EntireColumn.Hidden = False
   Set Rng = Ws.Range("A1").Resize(, Ws.Cells(3, Columns.Count).End(1).Column)
    For Each Cll In Rng
         If Cll.Value = Empty Then
             Cll.EntireColumn.Hidden = True
         End If
    Next
Ws.Range("A3").CurrentRegion.SpecialCells(12).Copy
        With Workbooks.Add
           Application.DisplayAlerts = False
                With .Sheets(1)
                    .Name = Ws.Name
                    .Range("A1").PasteSpecial 8
                    .Range("A1").PasteSpecial xlPasteValues
                    .Range("A1").PasteSpecial xlPasteFormats
                End With
                .Close True, Path & "\" & Ws.Name & ".xlsx"
        End With
        Rng.EntireColumn.Hidden = False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Quá tuyệt. Nhưng cho mình hỏi thêm là hiện list box chọn Sheet nào cần copy ra. File này thì tự động copy tất cả Sheet đang có.

Cảm ơn

 

[ndu96081631]

Chạy code sau:

Public Sub GPE()
Dim Ws As Worksheet, Cll As Range, Rng As Range, Path
Path = ThisWorkbook.Path
Application.ScreenUpdating = False
Application.SheetsInNewWorkbook = 1
For Each Ws In Worksheets
Ws.Cells(1, 1).Resize(, Columns.Count).EntireColumn.Hidden = False
   Set Rng = Ws.Range("A1").Resize(, Ws.Cells(3, Columns.Count).End(1).Column)
    For Each Cll In Rng
         If Cll.Value = Empty Then
             Cll.EntireColumn.Hidden = True
         End If
    Next
Ws.Range("A3").CurrentRegion.SpecialCells(12).Copy
        With Workbooks.Add
           Application.DisplayAlerts = False
                With .Sheets(1)
                    .Name = Ws.Name
                    .Range("A1").PasteSpecial 8
                    .Range("A1").PasteSpecial xlPasteValues
                    .Range("A1").PasteSpecial xlPasteFormats
                End With
                .Close True, Path & "\" & Ws.Name & ".xlsx"
        End With
        Rng.EntireColumn.Hidden = False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Tôi có cách này chỉ cần 1 vòng lập: Copy sheet ra file mới. Xong chọn các cells Blank ở dòng 1 rồi xóa cột của nó. Cuối cùng Close and Save. Thấy vậy đơn giản hơn

Sub SheetToFile()
  Dim wks As Worksheet, wkbSave As Workbook
  Dim rngDel As Range
  Dim sPath As String
  sPath = ThisWorkbook.Path & "\"
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  For Each wks In ThisWorkbook.Worksheets
    Set rngDel = Nothing
    wks.Copy
    Set wkbSave = ActiveWorkbook
    On Error Resume Next
    Set rngDel = wkbSave.Sheets(1).UsedRange.Resize(1).SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    If Not rngDel Is Nothing Then rngDel.EntireColumn.Delete
    wkbSave.SaveAs sPath & wks.Name, xlOpenXMLWorkbook
    wkbSave.Close True
  Next
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  MsgBox "Done!"
End Sub

Mời thí nghiệm!

 

[tranphuson]

Tôi có cách này chỉ cần 1 vòng lập: Copy sheet ra file mới. Xong chọn các cells Blank ở dòng 1 rồi xóa cột của nó. Cuối cùng Close and Save. Thấy vậy đơn giản hơn

Sub SheetToFile()
  Dim wks As Worksheet, wkbSave As Workbook
  Dim rngDel As Range
  Dim sPath As String
  sPath = ThisWorkbook.Path & "\"
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  For Each wks In ThisWorkbook.Worksheets
    Set rngDel = Nothing
    wks.Copy
    Set wkbSave = ActiveWorkbook
    On Error Resume Next
    Set rngDel = wkbSave.Sheets(1).UsedRange.Resize(1).SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    If Not rngDel Is Nothing Then rngDel.EntireColumn.Delete
    wkbSave.SaveAs sPath & wks.Name, xlOpenXMLWorkbook
    wkbSave.Close True
  Next
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  MsgBox "Done!"
End Sub

Mời thí nghiệm!

Cảm ơn Anh đã giúp đỡ và gợi ý