Tách sheet dựa vào điều kiện (1 người xem)

kokano90 · 21/8/20

Chào các anh chị ạ
Hiện tại em đang muốn tách sheet theo điều kiện với dữ liệu trong sheet1

Chẳng hạn em dữ liệu trong sheet1 của em tại cột A như hình.
Em muốn cứ 10 dòng sẽ tách thành 1 sheet. Cứ như vậy cho tới hết dữ liệu. Tên sheet được lấy theo thứ tự tăng dần ạ
Mong các anh chị, thầy cô giúp đỡ.
Em xin cám ơn nhiều ạ.

HieuCD · 21/8/20

kokano90 đã viết:
Chào các anh chị ạ
Hiện tại em đang muốn tách sheet theo điều kiện với dữ liệu trong sheet1
View attachment 243695
Chẳng hạn em dữ liệu trong sheet1 của em tại cột A như hình.
Em muốn cứ 10 dòng sẽ tách thành 1 sheet. Cứ như vậy cho tới hết dữ liệu. Tên sheet được lấy theo thứ tự tăng dần ạ
Mong các anh chị, thầy cô giúp đỡ.
Em xin cám ơn nhiều ạ.

Dùng code nào tùy thích

Mã:

Option Explicit
Sub ABC()
  Dim ws As Worksheet, eRow&, eCol&, i&, n&, k&
  Const SoDong = 10
  Const shName = "ABC"

  On Error Resume Next
  Application.ScreenUpdating = False
  With Sheets("sheet1")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    eCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    n = eRow \ SoDong + 1
    For i = 1 To n
      Sheets.Add After:=Sheets(Sheets.Count)
      ActiveSheet.Name = shName & i
      If Err.Number > 0 Then
        MsgBox ("Khong chay code lan 2")
        Application.ScreenUpdating = True
        Exit Sub
      End If
      .Range(.Cells((i - 1) * 10 + 1, 1), .Cells(i * 10, eCol)).Copy Range("A1")
    Next i
  End With
  Application.ScreenUpdating = True
End Sub

Sub ABC2()
  Dim ws As Worksheet, eRow&, eCol&, i&, n&, k&
  Const SoDong = 10
  Const shName = "ABC"

  On Error Resume Next
  Application.ScreenUpdating = False
  With Sheets("sheet1")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    eCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    n = eRow \ SoDong + 1
    For i = 1 To n
      Sheets.Add After:=Sheets(Sheets.Count)
      Do
        Err.Number = 0
        k = k + 1
        ActiveSheet.Name = shName & k
      Loop Until Err.Number = 0
      .Range(.Cells((i - 1) * 10 + 1, 1), .Cells(i * 10, eCol)).Copy Range("A1")
    Next i
  End With
  Application.ScreenUpdating = True
End Sub

kokano90 · 21/8/20

HieuCD đã viết:

Dùng code nào tùy thích

Mã:

Option Explicit
Sub ABC()
  Dim ws As Worksheet, eRow&, eCol&, i&, n&, k&
  Const SoDong = 10
  Const shName = "ABC"

  On Error Resume Next
  Application.ScreenUpdating = False
  With Sheets("sheet1")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    eCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    n = eRow \ SoDong + 1
    For i = 1 To n
      Sheets.Add After:=Sheets(Sheets.Count)
      ActiveSheet.Name = shName & i
      If Err.Number > 0 Then
        MsgBox ("Khong chay code lan 2")
        Application.ScreenUpdating = True
        Exit Sub
      End If
      .Range(.Cells((i - 1) * 10 + 1, 1), .Cells(i * 10, eCol)).Copy Range("A1")
    Next i
  End With
  Application.ScreenUpdating = True
End Sub

Sub ABC2()
  Dim ws As Worksheet, eRow&, eCol&, i&, n&, k&
  Const SoDong = 10
  Const shName = "ABC"

  On Error Resume Next
  Application.ScreenUpdating = False
  With Sheets("sheet1")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    eCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    n = eRow \ SoDong + 1
    For i = 1 To n
      Sheets.Add After:=Sheets(Sheets.Count)
      Do
        Err.Number = 0
        k = k + 1
        ActiveSheet.Name = shName & k
      Loop Until Err.Number = 0
      .Range(.Cells((i - 1) * 10 + 1, 1), .Cells(i * 10, eCol)).Copy Range("A1")
    Next i
  End With
  Application.ScreenUpdating = True
End Sub

Cám ơn thầy nhiều ạ!
Giả sử dữ liệu nó lớn quá. Chia thành 1000 sheet thì co vẻ không ổn thầy nhỉ?
Chẳng hạn có thêm 1 sheet Form cứ copy 10 dòng lần lượt sang sheet Form rồi làm gì tiếp đó ...
có được không thầy?

HieuCD · 21/8/20

kokano90 đã viết:
Cám ơn thầy nhiều ạ!
Giả sử dữ liệu nó lớn quá. Chia thành 1000 sheet thì co vẻ không ổn thầy nhỉ?
Chẳng hạn có thêm 1 sheet Form cứ copy 10 dòng lần lượt sang sheet Form rồi làm gì tiếp đó ...
có được không thầy?

Bạn muốn làm gì trên file thực tế?

kokano90 · 21/8/20

HieuCD đã viết:
Bạn muốn làm gì trên file thực tế?

em muốn xuất ra file text ấy ạ. đang ngồi dựa vào đoạn code của thầy. thấy thêm 1 sheet nữa có khi đỡ treo máy hơn ấy.
Nếu thầy có thời gian.Thầy đê em viết xong. rồi thầy coi sửa giúp em nhé. chứ thầy làm cả. em lại hem biết gì ạ
em cám ơn thầy nhiều

kokano90 · 21/8/20

HieuCD đã viết:
Bạn muốn làm gì trên file thực tế?

Mã:

Option Explicit
Sub XYZ()
Dim fso As Object, MyFile  As Object, iRow&, n&
Dim FileName As String, i As Long, Arr(), ws As Worksheet, j&
Set fso = CreateObject("Scripting.FileSystemObject")
Dim ws1 As Worksheet
    Const SoDong = 1000
    Const Ten = "ABC"
    Set ws = Sheets("sheet1")
    Set ws1 = Sheets("Form")
    iRow = ws.Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To iRow Step SoDong
        n = n + 1
        ws.Range("A" & i).Resize(SoDong).Copy ws1.Range("A1")
        Arr = ws1.Range("A1:A" & SoDong).Value
        FileName = ThisWorkbook.Path & "\" & Ten & n & ".txt"
        Set MyFile = fso.CreateTextFile(FileName, True, True)
        With MyFile
            For j = 1 To UBound(Arr)
                .WriteLine Arr(j, 1)
            Next
            .Close
        End With
        ws1.Columns("A:A").Clear
        Set MyFile = Nothing
    Next
    MsgBox "Da xong"
End Sub

Em có sử dụng file này với dữ liệu full dòng của excell mà chạy tới file 1000 là báo nỗi typename mising gì đó. Thầy chỉ em lỗi sai được không ạ?
Dùng mảng có khả thi không ạ

HieuCD · 21/8/20

kokano90 đã viết:

Mã:

Option Explicit
Sub XYZ()
Dim fso As Object, MyFile  As Object, iRow&, n&
Dim FileName As String, i As Long, Arr(), ws As Worksheet, j&
Set fso = CreateObject("Scripting.FileSystemObject")
Dim ws1 As Worksheet
    Const SoDong = 1000
    Const Ten = "ABC"
    Set ws = Sheets("sheet1")
    Set ws1 = Sheets("Form")
    iRow = ws.Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To iRow Step SoDong
        n = n + 1
        ws.Range("A" & i).Resize(SoDong).Copy ws1.Range("A1")
        Arr = ws1.Range("A1:A" & SoDong).Value
        FileName = ThisWorkbook.Path & "\" & Ten & n & ".txt"
        Set MyFile = fso.CreateTextFile(FileName, True, True)
        With MyFile
            For j = 1 To UBound(Arr)
                .WriteLine Arr(j, 1)
            Next
            .Close
        End With
        ws1.Columns("A:A").Clear
        Set MyFile = Nothing
    Next
    MsgBox "Da xong"
End Sub

Em có sử dụng file này với dữ liệu full dòng của excell mà chạy tới file 1000 là báo nỗi typename mising gì đó. Thầy chỉ em lỗi sai được không ạ?
Dùng mảng có khả thi không ạ

Mình chạy không bị lổi

Mã:

Sub XYZ()
  Dim fso As Object, MyFile  As Object, iRow&, n&
  Dim FileName As String, i&, SoDong&, Arr(), ws As Worksheet, j&
  Const Ten = "ABC"

  Set fso = CreateObject("Scripting.FileSystemObject")

  SoDong = 1000
  Set ws = Sheets("sheet1")
  iRow = ws.Range("A" & Rows.Count).End(xlUp).Row
  For i = 1 To iRow Step SoDong
    n = n + 1
    If i + SoDong > iRow Then SoDong = iRow - i + 1
    Arr = ws.Range("A" & i).Resize(SoDong).Value
    FileName = ThisWorkbook.Path & "\" & Ten & n & ".txt"
    Set MyFile = fso.CreateTextFile(FileName, True, True)
    With MyFile
      For j = 1 To UBound(Arr)
        .WriteLine Arr(j, 1)
      Next
      .Close
    End With
  Next i
    Set MyFile = Nothing
    MsgBox "Da xong"
End Sub

kokano90 · 22/8/20

Em cảm ơn thầy. Có ngồi debug. Nó bị lỗi do đúng dòng nó chứa dấu = trước chuỗi. Em cũng khắc phục được rồi ạ.
Cảm ơn thầy nhiều. Code dưới của thầy không cần them sheet phải không ạ

HieuCD · 22/8/20

kokano90 đã viết:
Em cảm ơn thầy. Có ngồi debug. Nó bị lỗi do đúng dòng nó chứa dấu = trước chuỗi. Em cũng khắc phục được rồi ạ.
Cảm ơn thầy nhiều. Code dưới của thầy không cần them sheet phải không ạ

Không cần thêm sheet mới

Tách sheet dựa vào điều kiện (1 người xem)

Người dùng đang xem chủ đề này

kokano90

Thành viên hoạt động

File đính kèm

HieuCD

Chuyên gia GPE

kokano90

Thành viên hoạt động

HieuCD

Chuyên gia GPE

kokano90

Thành viên hoạt động

kokano90

Thành viên hoạt động

HieuCD

Chuyên gia GPE

kokano90

Thành viên hoạt động

HieuCD

Chuyên gia GPE

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

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

Đếm ngược thời gian