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

Liên hệ QC
Hoangquyenbong

Hoangquyenbong

Thành viên hoạt động
Tham gia
13/7/18
Bài viết
199
Được thích
38
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 !
 

File đính kèm

  • Nhung.xls
    149.5 KB · Đọc: 12
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Hoangquyenbong đã viết:
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 !
Nhấp chuột vào đây để mở rộng...
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
Mã: 
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
 

File đính kèm

  • Nhung.xlsb
    30.3 KB · Đọc: 24
Upvote 0
HieuCD đã viết:
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
Mã: 
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
Nhấp chuột vào đây để mở rộng...
Dạ em cảm ơn bác nhiều ạ ! để em chạy thử ạ.
 
Upvote 0
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 ạ.
 
Upvote 0
HieuCD đã viết:
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
Mã: 
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
Nhấp chuột vào đây để mở rộng...
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ự ạ.
1625039618986.png
 
Upvote 0
befaint đã viết:
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
Nhấp chuột vào đây để mở rộng...
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 ạ.
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

LuuAnh980
Filter lọc có "mm" mà không thấy.
Trả lời
3
Đọc
48
VetMini
V
C
Giúp em viết công thức làm lịch thi đấu.
Trả lời
3
Đọc
48
VetMini
V
pupuchcha
  • Question
Viết code để tìm xích ma, mong mọi người giúp đỡ em ạ
Trả lời
4
Đọc
81
VetMini
V
C
  • Question
Tạo schedule chạy code VBA
Trả lời
8
Đọc
252
VetMini
V
V
Tách chuỗi bất kỳ vào các cột khi gặp ký tự -
Trả lời
6
Đọc
185
Duy Tùng 9x
Duy Tùng 9x
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom