Tách 1 dữ liệu sang nhiều sheet

[Dana123]

ANH CHỊ EM giúp tách 15 dữ liệu từ trên về qua sheet khác với , cứ 15 dữ liệu là tách qua sheet khác cứ như vậy cho đến khi hết dữ liệu. Em cảm ơn
KẾT QUẢ MONG MUỐN

 

[BuiQuangThuan]

ANH CHỊ EM giúp tách 15 dữ liệu từ trên về qua sheet khác với , cứ 15 dữ liệu là tách qua sheet khác cứ như vậy cho đến khi hết dữ liệu. Em cảm ơn
KẾT QUẢ MONG MUỐN

Đặt tên sheet như nào? Dữ liệu nhiều không? nếu nhiều thì tách ra nhiều sheet thế có ổn không

 

[Hai Lúa Miền Tây]

ANH CHỊ EM giúp tách 15 dữ liệu từ trên về qua sheet khác với , cứ 15 dữ liệu là tách qua sheet khác cứ như vậy cho đến khi hết dữ liệu. Em cảm ơn
KẾT QUẢ MONG MUỐN
View attachment 270002

Bạn thử code sau nhé:

Sub Tach_HLMT()
    Dim sht As Worksheet
    With CreateObject("ADODB.Recordset")
        .Open ("Select * from [Sheet1$]"), "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 Xml;Data Source=" & ThisWorkbook.FullName
        While Not .EOF
            Set sht = Worksheets.Add
            sht.Range("A2").CopyFromRecordset .DataSource, 15
        Wend
    End With
End Sub

 

[BuiQuangThuan]

Thêm 1 cách khác

Sub ABC()
    Dim i&, iRow&, K&, Ws As Worksheet
    With Sheet1
        iRow = .Range("A" & Rows.Count).End(3).Row
        For i = 2 To iRow Step 15
            K = K + 1
            Worksheets.Add , After:=Worksheets(Sheets.Count)
            Set Ws = ActiveSheet
            .Range("A1:D1").Copy Ws.Range("A1")
            .Range("A" & i).Resize(15, 4).Copy Ws.Range("A2")
            Ws.Name = Format(K, "000")
        Next
    End With
End Sub

 

[Dana123]

Thêm 1 cách khác

Sub ABC()
    Dim i&, iRow&, K&, Ws As Worksheet
    With Sheet1
        iRow = .Range("A" & Rows.Count).End(3).Row
        For i = 2 To iRow Step 15
            K = K + 1
            Worksheets.Add , After:=Worksheets(Sheets.Count)
            Set Ws = ActiveSheet
            .Range("A1:D1").Copy Ws.Range("A1")
            .Range("A" & i).Resize(15, 4).Copy Ws.Range("A2")
            Ws.Name = Format(K, "000")
        Next
    End With
End Sub

DẠ. Cảm ơn anh rất nhiều. em đã làm được

Bài đã được tự động gộp: 6/12/21

Bạn thử code sau nhé:

Sub Tach_HLMT()
    Dim sht As Worksheet
    With CreateObject("ADODB.Recordset")
        .Open ("Select * from [Sheet1$]"), "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 Xml;Data Source=" & ThisWorkbook.FullName
        While Not .EOF
            Set sht = Worksheets.Add
            sht.Range("A2").CopyFromRecordset .DataSource, 15
        Wend
    End With
End Sub

DẠ. Cảm ơn anh rất nhiều. em đã làm được