[TÁCH SHEETS] - SỬ DỤNG VÒNG LẶP VỚI 2 ĐIỀU KIỆN "FOR" (THỜI GIAN)

Liên hệ QC

subv

code vẽ người
Tham gia
29/6/12
Bài viết
36
Được thích
15
Giới tính
Nam
Nghề nghiệp
Tự do
Em chào các anh chị,

Hôm nay em có vấn đề này nhờ các anh chị xem qua và hướng dẫn giúp em ạ.

Em sử dụng vòng lặp for qua hai điều kiện để tạo tách thành các sheets mới, kèm theo đặt tên sheet mới theo điều kiện.
Code chạy, tách được sheets, tạo được tên sheets nhưng vùng dữ liệu cần copy sang sheets mới lại không có.
Anh chị xem giúp em ạ!
 

File đính kèm

  • CodesplitWb.png
    CodesplitWb.png
    176.7 KB · Đọc: 25
  • splitWb.png
    splitWb.png
    245.4 KB · Đọc: 24
  • Progress_NXB.xlsm
    322.2 KB · Đọc: 18
Em chào các anh chị,

Hôm nay em có vấn đề này nhờ các anh chị xem qua và hướng dẫn giúp em ạ.

Em sử dụng vòng lặp for qua hai điều kiện để tạo tách thành các sheets mới, kèm theo đặt tên sheet mới theo điều kiện.
Code chạy, tách được sheets, tạo được tên sheets nhưng vùng dữ liệu cần copy sang sheets mới lại không có.
Anh chị xem giúp em ạ!

Nhìn nhanh qua hình
Bạn thử chuyển lệnh copy xuống dưới sát ngay trước lệnh Paste, xem có tác dụng gì không
 
Thay cho Filter, Bạn cho thêm 2 vòng lặp nữa nằm trong 2 vòng lặp cũ để duyệt qua mảng [A6:O...]
Qua mỗi vòng lặp nếu tìm thấy dữ liệu đạt điều kiện ở Cột Q và R tương ứng với cột 2 và 14 của [A6:O...] thì cho vào mảng tạm, biến đếm k tăng lên 1
Lặp hết mảng [A6:O...] nếu k > 0 thì tạo sheet mới lấy kết quả mảng tạm đưa vào
Sau mỗi vòng lặp tìm mã và ngày thì dùng Erase để xóa mảng tạm.

Code dưới đây tôi viết tay chưa kiểm thử (tính lười của tôi hơi nặng)
PHP:
Sub test()
  Dim i&, j&, UB1&, UB2&, Arr, TotalArr(), ws As Worksheet
  Dim TimeLine, cst, lrQ&, lrR&, lrTemplate&, RC&
  With Sheets("Template")
    RC = Rows.Count
    lrTemplate = .Range("C" & RC).End(xlUp).Row
    lrQ = .Range("Q" & RC).End(xlUp).Row
    lrR = .Range("R" & RC).End(xlUp).Row
    Arr = .Range("A7:O" & lrTemplate).Value
    UB1 = UBound(Arr): UB2 = UBound(Arr, 2)
    For Each cst In .Range("Q7:Q" & lrQ)
      For Each TimeLine In .Range("R7:R" & lrR)
        Erase TotalArr: k = 0
          For i = 1 To UB1
            If Arr(i, 2) = cst.Value And Arr(i, 14) = TimeLine.Value Then
              k = k + 1
              For j = 1 To UB2
                ReDim Preserve TotalArr(1 To UB2, 1 To k)
                TotalArr(j, k) = Arr(i, j)
          Next j: End If: Next i
          If k > 0 Then
            Set ws = Sheets.Add(Sheets.Count)
            ws.[a7].Resize(k, UB2).Value = _
                    Application.Transpose(TotalArr)
            .[A6:O6].Copy ws.[A6:O6]
            ws.Name = cst.Value & "_" & Format(TimeLine.Value, "dd-mm-yyyy")
            Set ws = Nothing
          End If
    Next TimeLine, cst: End With
End Sub
 
Lần chỉnh sửa cuối:
Nhìn hình thì thấy 1 chỗ chắc chắn sai.
Mã:
.Parent.AutoFilter.Ranges.Copy

AutoFilter không có thuộc tính Ranges. Bạn không thấy báo lỗi vì trước đó có On Error Resume Next

Sửa thành
Mã:
.Parent.AutoFilter.Range.Copy

Ngoài ra tôi thấy ngồ ngộ
Mã:
.AutoFilter Field:=2, Criteria1:=cst
.AutoFilter Field:=14, Criteria1:=timeline

Cả hai đều là Criteria1?

Bạn thử chạy code đã sửa xem. Tôi nghĩ là sẽ không có kết quả lọc mà chỉ có tiêu đề thôi.
 
Thay cho Filter, Bạn cho thêm 2 vòng lặp nữa nằm trong 2 vòng lặp cũ để duyệt qua mảng [A6:O...]
Qua mỗi vòng lặp nếu tìm thấy dữ liệu đạt điều kiện ở Cột Q và R tương ứng với cột 2 và 14 của [A6:O...] thì cho vào mảng tạm, biến đếm k tăng lên 1
Lặp hết mảng [A6:O...] nếu k > 0 thì tạo sheet mới lấy kết quả mảng tạm đưa vào
Sau mỗi vòng lặp tìm mã và ngày thì dùng Erase để xóa mảng tạm.

Code dưới đây tôi viết tay chưa kiểm thử (tính lười của tôi hơi nặng)
PHP:
Sub test()
  Dim i&, j&, UB1&, UB2&, Arr, TotalArr(), ws As Worksheet
  Dim TimeLine, cst, lrQ&, lrR&, lrTemplate&, RC&
  With Sheets("Template")
    RC = Rows.Count
    lrTemplate = .Range("C" & RC).End(xlUp).Row
    lrQ = .Range("Q" & RC).End(xlUp).Row
    lrR = .Range("R" & RC).End(xlUp).Row
    Arr = .Range("A7:O" & lrTemplate).Value
    UB1 = UBound(Arr): UB2 = UBound(Arr)
    For Each cst In .Range("Q7:Q" & lrQ)
      For Each TimeLine In .Range("R7:R" & lrR)
        Erase TotalArr: k = 0
          For i = 1 To UB1
            If Arr(i, 2) = cst.Value And Arr(i, 14) = TimeLine.Value Then
              k = k + 1
              For j = 1 To UB2
                ReDim Preserve TotalArr(1 To UB2, 1 To k)
                TotalArr(j, k) = Arr(i, j)
          Next j: End If: Next i
          If k > 0 Then
            Set ws = Sheets.Add(Sheets.Count)
            ws.[a7].Resize(k, UB2).Value = _
                    Application.Transpose(TotalArr)
            .[A6:O6].Copy ws.[A6:O6]
            ws.Name = cst.Value & "_" & Format(TimeLine.Value, "dd-mm-yyyy")
            Set ws = Nothing
          End If
    Next TimeLine, cst: End With
End Sub
@HeSanbi
Mình chạy thì thấy... hình như code không phản hồi, cũng không báo lỗi luôn; chỉ riêng anh "k" léo sáng cái rồi thôi à
 
Thay cho Filter, Bạn cho thêm 2 vòng lặp nữa nằm trong 2 vòng lặp cũ để duyệt qua mảng [A6:O...]
Qua mỗi vòng lặp nếu tìm thấy dữ liệu đạt điều kiện ở Cột Q và R tương ứng với cột 2 và 14 của [A6:O...] thì cho vào mảng tạm, biến đếm k tăng lên 1
Lặp hết mảng [A6:O...] nếu k > 0 thì tạo sheet mới lấy kết quả mảng tạm đưa vào
Sau mỗi vòng lặp tìm mã và ngày thì dùng Erase để xóa mảng tạm.

Code dưới đây tôi viết tay chưa kiểm thử (tính lười của tôi hơi nặng)
PHP:
Sub test()
  Dim i&, j&, UB1&, UB2&, Arr, TotalArr(), ws As Worksheet
  Dim TimeLine, cst, lrQ&, lrR&, lrTemplate&, RC&
  With Sheets("Template")
    RC = Rows.Count
    lrTemplate = .Range("C" & RC).End(xlUp).Row
    lrQ = .Range("Q" & RC).End(xlUp).Row
    lrR = .Range("R" & RC).End(xlUp).Row
    Arr = .Range("A7:O" & lrTemplate).Value
    UB1 = UBound(Arr): UB2 = UBound(Arr)
    For Each cst In .Range("Q7:Q" & lrQ)
      For Each TimeLine In .Range("R7:R" & lrR)
        Erase TotalArr: k = 0
          For i = 1 To UB1
            If Arr(i, 2) = cst.Value And Arr(i, 14) = TimeLine.Value Then
              k = k + 1
              For j = 1 To UB2
                ReDim Preserve TotalArr(1 To UB2, 1 To k)
                TotalArr(j, k) = Arr(i, j)
          Next j: End If: Next i
          If k > 0 Then
            Set ws = Sheets.Add(Sheets.Count)
            ws.[a7].Resize(k, UB2).Value = _
                    Application.Transpose(TotalArr)
            .[A6:O6].Copy ws.[A6:O6]
            ws.Name = cst.Value & "_" & Format(TimeLine.Value, "dd-mm-yyyy")
            Set ws = Nothing
          End If
    Next TimeLine, cst: End With
End Sub
Sao mình thấy cái ub1 bằng ub2.
 
Lần chỉnh sửa cuối:
@HeSanbi
Mình chạy thì thấy... hình như code không phản hồi, cũng không báo lỗi luôn; chỉ riêng anh "k" léo sáng cái rồi thôi à
Ban xem.
Mã:
Sub test()
  Dim i&, j&, UB1&, UB2&, Arr, TotalArr(), ws As Worksheet
  Dim TimeLine, cst, lrQ&, lrR&, lrTemplate&, RC&
  With Sheets("Template")
    RC = Rows.Count
    lrTemplate = .Range("C" & RC).End(xlUp).Row
    lrQ = .Range("Q" & RC).End(xlUp).Row
    lrR = .Range("R" & RC).End(xlUp).Row
    Arr = .Range("A7:O" & lrTemplate).Value
    UB1 = UBound(Arr, 1): UB2 = UBound(Arr, 2)
    For Each cst In .Range("Q7:Q" & lrQ)
      ReDim TotalArr(1 To UB1, 1 To UB2)
      For Each TimeLine In .Range("R7:R" & lrR)
          For i = 1 To UB1
            If Arr(i, 2) = cst.Value And Arr(i, 14) = TimeLine.Value Then
              k = k + 1
              For j = 1 To UB2
                TotalArr(k, j) = Arr(i, j)
          Next j: End If: Next i
          If k > 0 Then
            Set ws = Sheets.Add(Sheets(Sheets.Count))
            ws.[a7].Resize(k, UB2).Value = TotalArr
            .[A6:O6].Copy ws.[A6:O6]
            ws.Name = cst.Value & "_" & Format(TimeLine.Value, "dd-mm-yyyy")
            Set ws = Nothing
            Erase TotalArr: k = 0
          End If
    Next TimeLine, cst: End With
End Sub
 
Web KT
Back
Top Bottom