Nhờ viết câu lệnh để tự tạo nhiều sheet với nội dung khác nhau.

[Hoangquyenbong]

Em xin chúc năm mới cả nhà ! Kính chúc tất cả thành viên trên diễn đàn năm mới sức khỏe, thành công và hạnh phúc !
Em có file dữ liệu muốn nhờ diễn đàn viết giúp em câu lệnh VBA để tạo ra nhiều sheet tương ứng với mỗi tên sheet cho trước ở bảng dữ liệu. Chi tiết em đã ghi rõ tại sheet Nhung(X025Z-TW) trong file đính kèm ạ. Lượng dữ liệu tại sheet File Dulieu sẽ rất nhiều ạ. Mong cả nhà giúp em ạ ! Nếu có thông tin nào chưa rõ hoặc em giải thích thiếu, chưa hiểu hy vọng cả nhà phản hồi lại giúp em.
Em cảm ơn rất nhiều !

 

[HieuCD]

Em xin chúc năm mới cả nhà ! Kính chúc tất cả thành viên trên diễn đàn năm mới sức khỏe, thành công và hạnh phúc !
Em có file dữ liệu muốn nhờ diễn đàn viết giúp em câu lệnh VBA để tạo ra nhiều sheet tương ứng với mỗi tên sheet cho trước ở bảng dữ liệu. Chi tiết em đã ghi rõ tại sheet Nhung(X025Z-TW) trong file đính kèm ạ. Lượng dữ liệu tại sheet File Dulieu sẽ rất nhiều ạ. Mong cả nhà giúp em ạ ! Nếu có thông tin nào chưa rõ hoặc em giải thích thiếu, chưa hiểu hy vọng cả nhà phản hồi lại giúp em.
Em cảm ơn rất nhiều !

Thêm sheet "Mau" là sheet gốc copy cho các sheet kết quả
Dữ liệu phải được sort như trong file
Chạy code

Sub XYZ()
  Dim sArr(), Res(), sh As Worksheet, Dic As Object
  Dim sRow&, i&, k&, c&, jC&, tenSh$, mau$, iKey$
 
  Application.ScreenUpdating = False
  Set Dic = CreateObject("scripting.dictionary")
  With Sheets("File Dulieu")
    sArr = .Range("A5:M" & .Range("M" & Rows.Count).End(xlUp).Row + 1).Value
  End With
  sRow = UBound(sArr) - 1
  For i = 1 To sRow
    If tenSh <> sArr(i, 13) Then 'Sheet ket qua moi
      Res = Sheets("Mau").Range("S7:AI15").Value
      tenSh = sArr(i, 13)
      Call TaoSheet(tenSh, sh)
      sh.Range("C2") = sArr(i, 9):    sh.Range("H2") = sArr(i, 10)
      sh.Range("C3") = sArr(i, 11):   sh.Range("H3") = sArr(i, 12)
      sh.Range("S2") = sArr(i, 1):    sh.Range("Z2") = sArr(i, 8)
      Dic.RemoveAll: mau = Empty: k = 1: c = 1
    End If
    
    If mau <> sArr(i, 5) Then 'Them dong ket qua
      mau = sArr(i, 5)
      k = k + 1
      Res(k, 1) = mau
    End If
    
    iKey = sArr(i, 6) 'Xet cot ket qua
    If Dic.exists(iKey) = False Then
      c = c + 1
      Dic.Add iKey, c
      Res(1, c) = iKey
    End If
    jC = Dic.Item(iKey)
    Res(k, jC) = sArr(i, 4) 'Ket qua
    
    If tenSh <> sArr(i + 1, 13) Then 'Gan ket qua cho sheet
      sh.Range("S7").Resize(UBound(Res), UBound(Res, 2)) = Res
    End If
  Next i
  Application.ScreenUpdating = True
End Sub

Private Sub TaoSheet(tenSh, sh)
  On Error Resume Next
  If TypeName(Sheets(tenSh).Name) <> "String" Then
    Sheets("Mau").Copy After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = tenSh
  End If
  Set sh = Sheets(tenSh)
  On Error GoTo 0
End Sub

 

[Hoangquyenbong]

Thêm sheet "Mau" là sheet gốc copy cho các sheet kết quả
Dữ liệu phải được sort như trong file
Chạy code

Sub XYZ()
  Dim sArr(), Res(), sh As Worksheet, Dic As Object
  Dim sRow&, i&, k&, c&, jC&, tenSh$, mau$, iKey$

  Application.ScreenUpdating = False
  Set Dic = CreateObject("scripting.dictionary")
  With Sheets("File Dulieu")
    sArr = .Range("A5:M" & .Range("M" & Rows.Count).End(xlUp).Row + 1).Value
  End With
  sRow = UBound(sArr) - 1
  For i = 1 To sRow
    If tenSh <> sArr(i, 13) Then 'Sheet ket qua moi
      Res = Sheets("Mau").Range("S7:AI15").Value
      tenSh = sArr(i, 13)
      Call TaoSheet(tenSh, sh)
      sh.Range("C2") = sArr(i, 9):    sh.Range("H2") = sArr(i, 10)
      sh.Range("C3") = sArr(i, 11):   sh.Range("H3") = sArr(i, 12)
      sh.Range("S2") = sArr(i, 1):    sh.Range("Z2") = sArr(i, 8)
      Dic.RemoveAll: mau = Empty: k = 1: c = 1
    End If
   
    If mau <> sArr(i, 5) Then 'Them dong ket qua
      mau = sArr(i, 5)
      k = k + 1
      Res(k, 1) = mau
    End If
   
    iKey = sArr(i, 6) 'Xet cot ket qua
    If Dic.exists(iKey) = False Then
      c = c + 1
      Dic.Add iKey, c
      Res(1, c) = iKey
    End If
    jC = Dic.Item(iKey)
    Res(k, jC) = sArr(i, 4) 'Ket qua
   
    If tenSh <> sArr(i + 1, 13) Then 'Gan ket qua cho sheet
      sh.Range("S7").Resize(UBound(Res), UBound(Res, 2)) = Res
    End If
  Next i
  Application.ScreenUpdating = True
End Sub

Private Sub TaoSheet(tenSh, sh)
  On Error Resume Next
  If TypeName(Sheets(tenSh).Name) <> "String" Then
    Sheets("Mau").Copy After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = tenSh
  End If
  Set sh = Sheets(tenSh)
  On Error GoTo 0
End Sub

Dạ em cảm ơn bác nhiều ạ ! để em chạy thử ạ.

 

[Hoangquyenbong]

Dạ em cảm ơn bác nhiều ạ ! để em chạy thử ạ.

File chạy cho kết quả như ý rồi bác ạ. Em cảm ơn bác rất nhiều !

 

[thao1111]

Em muốn sort theo thứ tự M-1; M-2; M-12; M-3; M-102; M-40 từ nhỏ đến lớn phải làm thế nào ạ?
Nhờ các Bác giúp dùm em với.
Cảm ơn nhiều ạ.

 

[Hoangquyenbong]

Thêm sheet "Mau" là sheet gốc copy cho các sheet kết quả
Dữ liệu phải được sort như trong file
Chạy code

Sub XYZ()
  Dim sArr(), Res(), sh As Worksheet, Dic As Object
  Dim sRow&, i&, k&, c&, jC&, tenSh$, mau$, iKey$
 
  Application.ScreenUpdating = False
  Set Dic = CreateObject("scripting.dictionary")
  With Sheets("File Dulieu")
    sArr = .Range("A5:M" & .Range("M" & Rows.Count).End(xlUp).Row + 1).Value
  End With
  sRow = UBound(sArr) - 1
  For i = 1 To sRow
    If tenSh <> sArr(i, 13) Then 'Sheet ket qua moi
      Res = Sheets("Mau").Range("S7:AI15").Value
      tenSh = sArr(i, 13)
      Call TaoSheet(tenSh, sh)
      sh.Range("C2") = sArr(i, 9):    sh.Range("H2") = sArr(i, 10)
      sh.Range("C3") = sArr(i, 11):   sh.Range("H3") = sArr(i, 12)
      sh.Range("S2") = sArr(i, 1):    sh.Range("Z2") = sArr(i, 8)
      Dic.RemoveAll: mau = Empty: k = 1: c = 1
    End If
   
    If mau <> sArr(i, 5) Then 'Them dong ket qua
      mau = sArr(i, 5)
      k = k + 1
      Res(k, 1) = mau
    End If
   
    iKey = sArr(i, 6) 'Xet cot ket qua
    If Dic.exists(iKey) = False Then
      c = c + 1
      Dic.Add iKey, c
      Res(1, c) = iKey
    End If
    jC = Dic.Item(iKey)
    Res(k, jC) = sArr(i, 4) 'Ket qua
   
    If tenSh <> sArr(i + 1, 13) Then 'Gan ket qua cho sheet
      sh.Range("S7").Resize(UBound(Res), UBound(Res, 2)) = Res
    End If
  Next i
  Application.ScreenUpdating = True
End Sub

Private Sub TaoSheet(tenSh, sh)
  On Error Resume Next
  If TypeName(Sheets(tenSh).Name) <> "String" Then
    Sheets("Mau").Copy After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = tenSh
  End If
  Set sh = Sheets(tenSh)
  On Error GoTo 0
End Sub

Chào bác #HieuCD !
Bác cho em hỏi chút ạ, sáng em vẫn làm bình thường nhưng bây giờ nó báo lỗi mà em không biết nguyên nhân và cách khắc phục lỗi ạ. Bác xem lỗi như dưới ảnh và hướng dẫn em với ạ. em cảm ơn. ( lỗi này xuất hiện sau khi em tự thêm 1 sheet mới ). Nhưng khi em mở file của bác trên diễn đàn về thì nó cũng báo lỗi tương tự ạ.

 

[befaint]

báo lỗi mà em không biết nguyên nhân và cách khắc phục lỗi

Mình khởi động lại máy tính.

Nếu không được thì mua phần mềm cài đặt mới.

 

[Hoangquyenbong]

Mình khởi động lại máy tính.

Nếu không được thì mua phần mềm cài đặt mới.

View attachment 261562

Dạ em cảm ơn bác nhiều !
Bác ơi, vậy file nào của em nó cũng có thông báo trong ngoặc như vậy ạ( nó khá lâu rồi ạ), kể cả outlook luôn ạ. Em có chạy thử vài file khác nó không có vấn đề gì ạ. Em sẽ làm theo hướng dẫn của bác xong em sẽ phản hồi lại ạ.

 

[Hoangquyenbong]

Mình khởi động lại máy tính.

Nếu không được thì mua phần mềm cài đặt mới.

View attachment 261562

Dạ em đã khởi động lại máy và mọi thứ đã trở lại bình thường rồi ạ. Em cảm ơn bác nhiều ạ !