TÁCH FILE EXCEL RA NHIỀU FILE

[tuanxitin]

Dear anh/chị
có vấn đề này nhờ anh/chị xem giúp em
Em có file sheet tổng hợp "sheet 1", em có viết ra các code
+ Tách sheet
+ Xuất file
+ Xóa sheet đã tách
Tuy nhiên, code xuất file em gặp vấn đề, nó xuất các sheet trong excel. Làm cách nào nó không xuất sheet tổng hợp "sheet 1" không ạ.
Tks anh chị

 

[quick87]

Dear anh/chị
có vấn đề này nhờ anh/chị xem giúp em
Em có file sheet tổng hợp "sheet 1", em có viết ra các code
+ Tách sheet
+ Xuất file
+ Xóa sheet đã tách
Tuy nhiên, code xuất file em gặp vấn đề, nó xuất các sheet trong excel. Làm cách nào nó không xuất sheet tổng hợp "sheet 1" không ạ.
Tks anh chị

Bạn thử code sau nhé:

Option Explicit
Sub zaq()
Dim Rng As Range, endR As Long
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
With ActiveSheet
    endR = .Range("A650000").End(xlUp).Row
    .Range("A3:A" & endR).Copy Range("G3")
    .Range("G3:G" & endR).RemoveDuplicates 1, xlNo
    .Range("A2").CurrentRegion.AutoFilter
For Each Rng In .Range("G3:G" & .Range("G3").End(xlDown).Row)
    With .Range("A2").CurrentRegion
        .AutoFilter 1, Rng.Value
        .Copy
    End With
    Workbooks.Add: ActiveSheet.Paste
    ActiveSheet.Columns("A:B").AutoFit
    With ActiveWorkbook
        .SaveAs ThisWorkbook.Path & "\" & Rng, FileFormat:=xlOpenXMLWorkbook
        .Close
    End With
Next
    .Range("A2").CurrentRegion.AutoFilter
End With
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox "Done"

End Sub

 

[PacificPR]

Dear anh/chị
có vấn đề này nhờ anh/chị xem giúp em
Em có file sheet tổng hợp "sheet 1", em có viết ra các code
+ Tách sheet
+ Xuất file
+ Xóa sheet đã tách
Tuy nhiên, code xuất file em gặp vấn đề, nó xuất các sheet trong excel. Làm cách nào nó không xuất sheet tổng hợp "sheet 1" không ạ.
Tks anh chị

Bạn sửa lại như vầy

Sub Splitbook()
'Update20190816
    Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
    If Left(xWs.Name, 5) <> "Sheet" Then
        xWs.Copy
        Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
        Application.ActiveWorkbook.Close False
    End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Trong cái Sub Tách Sheet của bạn chưa có dòng lệnh kiểm tra Sheet đã tồn tại

Sub tach_sheet_TH_thanh_nhieu_sheet()
    Dim lr As Long
    Dim rng As Range, cel As Range
    Dim Ws As Worksheet
Set Ws = Sheets("Sheet1")
lr = Ws.Range("a" & Rows.Count).End(xlUp).Row
Set rng = Ws.Range("a2:b" & lr)
For Each cel In Range("g3:g5")
    rng.AutoFilter field:=1, Criteria1:=cel.Value
    If Not WsExit(cel.Value) Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = cel.Value
    Else
        Sheets(cel.Value).Move after:=Worksheets(Worksheets.Count)
    End If
    rng.SpecialCells(xlCellTypeVisible).Copy Sheets(cel.Value).Cells(1, 1)
    Ws.UsedRange.EntireColumn.AutoFit
Next cel
rng.AutoFilter
Set Ws = Nothing: Set rng = Nothing: Set cel = Nothing
End Sub
Public Function WsExit(wsName As String) As Boolean
    On Error Resume Next
    WsExit = CBool(Len(Worksheets(wsName).Name) > 0)
End Function

 

[tuanxitin]

Bạn thử code sau nhé:

Option Explicit
Sub zaq()
Dim Rng As Range, endR As Long
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
With ActiveSheet
    endR = .Range("A650000").End(xlUp).Row
    .Range("A3:A" & endR).Copy Range("G3")
    .Range("G3:G" & endR).RemoveDuplicates 1, xlNo
    .Range("A2").CurrentRegion.AutoFilter
For Each Rng In .Range("G3:G" & .Range("G3").End(xlDown).Row)
    With .Range("A2").CurrentRegion
        .AutoFilter 1, Rng.Value
        .Copy
    End With
    Workbooks.Add: ActiveSheet.Paste
    ActiveSheet.Columns("A:B").AutoFit
    With ActiveWorkbook
        .SaveAs ThisWorkbook.Path & "\" & Rng, FileFormat:=xlOpenXMLWorkbook
        .Close
    End With
Next
    .Range("A2").CurrentRegion.AutoFilter
End With
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox "Done"

End Sub

em cảm ơn

Bài đã được tự động gộp: 31/5/20

Bạn sửa lại như vầy

Sub Splitbook()
'Update20190816
    Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
    If Left(xWs.Name, 5) <> "Sheet" Then
        xWs.Copy
        Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
        Application.ActiveWorkbook.Close False
    End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Trong cái Sub Tách Sheet của bạn chưa có dòng lệnh kiểm tra Sheet đã tồn tại

Sub tach_sheet_TH_thanh_nhieu_sheet()
    Dim lr As Long
    Dim rng As Range, cel As Range
    Dim Ws As Worksheet
Set Ws = Sheets("Sheet1")
lr = Ws.Range("a" & Rows.Count).End(xlUp).Row
Set rng = Ws.Range("a2:b" & lr)
For Each cel In Range("g3:g5")
    rng.AutoFilter field:=1, Criteria1:=cel.Value
    If Not WsExit(cel.Value) Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = cel.Value
    Else
        Sheets(cel.Value).Move after:=Worksheets(Worksheets.Count)
    End If
    rng.SpecialCells(xlCellTypeVisible).Copy Sheets(cel.Value).Cells(1, 1)
    Ws.UsedRange.EntireColumn.AutoFit
Next cel
rng.AutoFilter
Set Ws = Nothing: Set rng = Nothing: Set cel = Nothing
End Sub
Public Function WsExit(wsName As String) As Boolean
    On Error Resume Next
    WsExit = CBool(Len(Worksheets(wsName).Name) > 0)
End Function

e cảm ơn

 

[ishikawangocthuy]

mọi người cho em hỏi ké em muốn tách file ẽcel từ file tổng nếu thoả mãn điều kiện.
file
của em có các cột như hình xét tất cả các hàng ở cột B nếu cột hàng nào ở cột B còn trống thì sẽ xuất tất cả các giá tri sang một file mới và em đặt file này là newfile còn file chuắ dữ liệu là template,em có tìm hiểu và là theo nhưng ko ra ai có thể giúp em đuợc không ah.
Đây là code của em
Option Explicit
Sub macro1()


Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("template")

Dim cmax As Long
cmax = ws1.Range("A65536").End(xlUp).Row

ws1.Sort.SortFields.Clear
'ws1.Sort.SortFields.Add Key:=ws1.Range("B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ws1.Sort

.SetRange ws1.Range("A2:K" & cmax)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

Dim filepath As String
filepath = ThisWorkbook.Path & "\newfile.xlsm"

Dim i As Long, j As Long
Dim torihiki As String

For i = 2 To cmax
torihiki = Worksheets("template").Cells(i, "B").Value

If torihiki <> "" Then


Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & torihiki
Application.DisplayAlerts = True

ActiveWorkbook.Close
End If

torihiki = Worksheets("template").Cells(i, "B")
Workbooks.Open filepath
ActiveSheet.Name = torihiki

j = 2


Worksheets(torihiki).Range("A" & j).Value = ws1.Range("A" & i).Value
Worksheets(torihiki).Range("B" & j).Value = ws1.Range("B" & i).Value
Worksheets(torihiki).Range("C" & j).Value = ws1.Range("C" & i).Value
Worksheets(torihiki).Range("D" & j).Value = ws1.Range("D" & i).Value
Worksheets(torihiki).Range("E" & j).Value = ws1.Range("E" & i).Value
Worksheets(torihiki).Range("F" & j).Value = ws1.Range("F" & i).Value
Worksheets(torihiki).Range("G" & j).Value = ws1.Range("G" & i).Value
Worksheets(torihiki).Range("H" & j).Value = ws1.Range("H" & i).Value
Worksheets(torihiki).Range("J" & j).Value = ws1.Range("J" & i).Value
Worksheets(torihiki).Range("K" & j).Value = ws1.Range("K" & i).Value

j = j + 1
Next

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & torihiki
Application.DisplayAlerts = True

ActiveWorkbook.Close

End Sub