[Giúp]: Macro lấy data vào nhiều sheet mới có điều kiện

[timhieu02]

Em chào các anh/ chị,
Sau 1 hồi lăn lộn với macro nhưng vẫn chưa ra được kết quả, bây giờ em mới post lên diễn đàn mong các anh chị giúp em bài toán khó này vì chiều mai em nạp bài (☹)
Em gửi file ví dụ đính kèm và bên dưới là mô tả:

• Trong file gốc có sheet: “Data”
• Sau khi chạy macro thì tạo ra các sheet mới, với quy luật:
  • Tất cả các sheet mới tạo ra đều giữ nguyên data cột A + B
  • Data lần lượt ở sheet mới là: (dựa trên sheet “Data”)
    • Nếu Cột C :
      • thì đặt tên sheet là: “2” (2 là giá trị ở Row C1)
      • Giữ data data cột C, sau đó xóa data các cột còn lại
    • Nếu Cột D:
      • thì đặt tên sheet là: “5” (5 là giá trị ở Row D1)
      • Giữ data data cột D, sau đó xóa data các cột còn lại
    • Nếu Cột E:
      • thì đặt tên sheet là: “8” (8 là giá trị ở Row E1)
      • Giữ data data cột E, sau đó xóa data các cột còn lại
    • Nếu Cột F:
      • thì đặt tên sheet là: “11” (11 là giá trị ở Row F1)
      • Giữ data data cột F, sau đó xóa data các cột còn lại
    • Nếu Cột G:
      • thì đặt tên sheet là: “20” (20 là giá trị ở Row G1)
      • Giữ data data cột G, sau đó xóa data các cột còn lại

Tuy đã khuya, mong các anh chị nhín chút thời gian giúp em với.

Cám ơn rất nhiều

 

[be_09]

Em chào các anh/ chị,
Sau 1 hồi lăn lộn với macro nhưng vẫn chưa ra được kết quả, bây giờ em mới post lên diễn đàn mong các anh chị giúp em bài toán khó này vì chiều mai em nạp bài (☹)
Em gửi file ví dụ đính kèm và bên dưới là mô tả:

• Trong file gốc có sheet: “Data”
• Sau khi chạy macro thì tạo ra các sheet mới, với quy luật:
  • Tất cả các sheet mới tạo ra đều giữ nguyên data cột A + B
  • Data lần lượt ở sheet mới là: (dựa trên sheet “Data”)
    • Nếu Cột C :
      • thì đặt tên sheet là: “2” (2 là giá trị ở Row C1)
      • Giữ data data cột C, sau đó xóa data các cột còn lại
    • Nếu Cột D:
      • thì đặt tên sheet là: “5” (5 là giá trị ở Row D1)
      • Giữ data data cột D, sau đó xóa data các cột còn lại
    • Nếu Cột E:
      • thì đặt tên sheet là: “8” (8 là giá trị ở Row E1)
      • Giữ data data cột E, sau đó xóa data các cột còn lại
    • Nếu Cột F:
      • thì đặt tên sheet là: “11” (11 là giá trị ở Row F1)
      • Giữ data data cột F, sau đó xóa data các cột còn lại
    • Nếu Cột G:
      • thì đặt tên sheet là: “20” (20 là giá trị ở Row G1)
      • Giữ data data cột G, sau đó xóa data các cột còn lại

Tuy đã khuya, mong các anh chị nhín chút thời gian giúp em với.

Cám ơn rất nhiều

Bạn không nên đăng nhiều bài viết, đọc lại nội quy để hiểu mình vi phạm cái gì.
Đây là bài viết kia

 

[HeSanbi]

Ông thầy của bạn ra đề khá hay đấy, sai sót một tí cũng rất là mệt
Ông đã mẹo như thế này:
Cho bạn đặt tên sheet là số. không đều nhau
Tuy nhiên trong Index của Sheets cũng cùng nhận là số nó bắt đầu từ 1.
Nếu sai sót bạn cho vòng lặp duyệt các số và mẹo ở đây là bắt buộc bạn phải dùng phương thức CStr để convert sang chuỗi
để kiểm tra xem Sheet Name có cồn tại hay chưa.
Arr(4) = 8
Tức là Worksheets( Arr(4) ) tương đương Worksheets(8 )
Tuy nhiên nếu kiểm tra Name thì phải là Worksheets(CStr(Arr(4)) )

Bạn kiểm tra code nhé:

Option Explicit
Sub Run_AddNewSheetByDK()
  Dim LData, LCol&, I&, J&, WS As Worksheet, Row&
  With ThisWorkbook.Worksheets(1)
    LCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    Row = .Cells(Rows.Count,1).End(xlUp).Row  
    LData = .Range("A1").Resize(, LCol).Value
  End With
  If LCol < 3 Then Exit Sub
  On Error Resume Next
  For I = 3 To LCol
    Set WS = Worksheets(CStr(LData(1, I)))
    If Err.Number = 0 Then GoTo NextFor1
    Err.Clear
    Set WS = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    With ThisWorkbook.Worksheets(1)
      Application.CutCopyMode = False
      .Range("A1").Resize(Row, 2).Copy WS.Range("A1").Resize(Row, 2)
      .Range("A1")(1, I).Resize(Row, 1).Copy WS.Range("A1")(1, 3).Resize(Row, 1)
      .Range("A:C").Copy
      WS.Range("A:C").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
      SkipBlanks:=False, Transpose:=False
      Application.CutCopyMode = True
      WS.Name = LData(1, I)
    End With
NextFor1:
  Next
  On Error GoTo 0
End Sub

 

[VetMini]

Ông thầy của bạn ra đề khá hay đấy, sai sót một tí cũng rất là mệt
Ông đã mẹo như thế này:
...

Bài này chủ yếu là record macro rồi chỉnh sửa chút xíu thôi.
Nó hay và mẹo ở chỗ là code cho hoành tráng thì biết ngay là đi hỏi xin code.

 

[timhieu02]

Bạn không nên đăng nhiều bài viết, đọc lại nội quy để hiểu mình vi phạm cái gì.
Đây là bài viết kia

View attachment 217298

Dạ. em cám ơn anh be09. tối qua em thấy đã post vào topic "Hàm và công thúc Excel" không đúng. nên post lại topic "Macro". sau đó quay lại xóa nhưng không biết cách. Nhờ thầy và admiin delete giúp mình ở mục "Hàm và công thúc Excel" . Sẽ khắc phục ạ

 

[timhieu02]

Ông thầy của bạn ra đề khá hay đấy, sai sót một tí cũng rất là mệt
Ông đã mẹo như thế này:
Cho bạn đặt tên sheet là số. không đều nhau
Tuy nhiên trong Index của Sheets cũng cùng nhận là số nó bắt đầu từ 1.
Nếu sai sót bạn cho vòng lặp duyệt các số và mẹo ở đây là bắt buộc bạn phải dùng phương thức CStr để convert sang chuỗi
để kiểm tra xem Sheet Name có cồn tại hay chưa.
Arr(4) = 8
Tức là Worksheets( Arr(4) ) tương đương Worksheets(8 )
Tuy nhiên nếu kiểm tra Name thì phải là Worksheets(CStr(Arr(4)) )

Bạn kiểm tra code nhé:

Option Explicit
Sub Run_AddNewSheetByDK()
  Dim LData, LCol&, I&, J&, WS As Worksheet
  Const Row = 12
  With ThisWorkbook.Worksheets(1)
    LCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    LData = .Range("A1").Resize(, LCol).Value
  End With
  If LCol < 3 Then Exit Sub
  On Error Resume Next
  For I = 3 To LCol
    Set WS = Worksheets(CStr(LData(1, I)))
    If Err.Number = 0 Then GoTo NextFor1
    Err.Clear
    Set WS = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    With ThisWorkbook.Worksheets(1)
      Application.CutCopyMode = False
      .Range("A1").Resize(Col, 2).Copy WS.Range("A1").Resize(Row, 2)
      .Range("A1")(1, I).Resize(Row, 1).Copy WS.Range("A1")(1, 3).Resize(Row, 1)
      .Range("A:C").Copy
      WS.Range("A:C").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
      SkipBlanks:=False, Transpose:=False
      Application.CutCopyMode = True
      WS.Name = LData(1, I)
    End With
NextFor1:
  Next
  On Error GoTo 0
End Sub

Cảm ơn bạn,

Mình chạy thì nó báo lổi như bên dưới.
Với lại data mình là ví dụ, thật tế thì nó có hơn trăm cột và hơn trăm dòng.
Có gì bạn xem giúp với nhé.

 

[HeSanbi]

Bạn sửa lại là Row
1000 cột cũng tự động thôi, trăm dòng thì
Xóa bỏ Const Row
Dim Row%:
Row = .Cells(Rows.Count,1).End(xlUp).Row
Vào Block With đầu tiên

 

[timhieu02]

Bạn sửa lại là Row
1000 cột cũng tự động thôi, trăm dòng thì
Xóa bỏ Const Row
Dim Row%:
Row = .Cells(Rows.Count,1).End(xlUp).Row
Vào Block With đầu tiên

Chạy được rồi. sáng sớm thứ 7 làm phiền bạn! Cám ơn bạn nhiều nhé