Xin Code VBA gán thời gian vào vùng dữ liệu theo điều kiện nhiều điều kiện

Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài
Có
X

xuannam1911

Thành viên mới
Tham gia
30/9/22
Bài viết
9
Được thích
7
Chào mọi người!
Mình xin trợ giúp code VBA gán thời gian theo nhiều điều kiện như sau:
Trong Sheet1 mình có dữ liệu các line/shift/sequence và date
Mình cần gán thời gian chạy theo các điều kiện trên sao cho:
- nếu cùng 1 line cùng shift, cùng ngày và có nhiều sequence theo thứ tự từ 1 đến xxx... thì macro sẽ gán vào cột Start:
+ Sequence 1 : DS -> 07:00:00AM hoặc NS -> 07:00:00PM
+ Sequence 2 sẽ bằng end của sequence 1
+ Sequence 3 sẽ bằng end của sequence 2
+ ,....
Mong được mọi người giúp đỡ, mình cảm ơn!
1717063350624.png
 

File đính kèm

  • test.xlsm
    25.9 KB · Đọc: 10
Sắp xếp theo thời gian sắp xếp theo bầu chọn
xuannam1911 đã viết:
Chào mọi người!
Mình xin trợ giúp code VBA gán thời gian theo nhiều điều kiện như sau:
Trong Sheet1 mình có dữ liệu các line/shift/sequence và date
Mình cần gán thời gian chạy theo các điều kiện trên sao cho:
- nếu cùng 1 line cùng shift, cùng ngày và có nhiều sequence theo thứ tự từ 1 đến xxx... thì macro sẽ gán vào cột Start:
+ Sequence 1 : DS -> 07:00:00AM hoặc NS -> 07:00:00PM
+ Sequence 2 sẽ bằng end của sequence 1
+ Sequence 3 sẽ bằng end của sequence 2
+ ,....
Mong được mọi người giúp đỡ, mình cảm ơn!
View attachment 301251
Nhấp chuột vào đây để mở rộng...
Kiểm tra lại . . .
Mã: 
Sub xyz()
  Dim arr(), res(), a, b, dic As Object, key
  Dim sRow&, i&, tAM As Date

  Set dic = CreateObject("Scripting.Dictionary")
  tAM = 7 / 24 '07:00:00 AM
  arr = Sheet1.Range("A2", Sheet1.Range("I" & Rows.Count).End(xlUp)).Value
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To 2)
  For i = 1 To sRow
    key = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 4)
    If dic.exists(key) = False Then
      ReDim a(1 To arr(i, 3))
    Else
      a = dic(key)
      If arr(i, 3) > UBound(a) Then ReDim Preserve a(1 To arr(i, 3))
    End If
    a(arr(i, 3)) = i
    dic(key) = a
  Next i
  For Each key In dic.keys
    a = dic(key)
    If a(1) > 0 Then
      res(a(1), 1) = arr(a(1), 4) + tAM
      If arr(a(1), 2) = "NS" Then res(a(1), 1) = res(a(1), 1) + 1 / 2
      res(a(1), 2) = res(a(1), 1) + arr(a(1), 9)
    End If
    For i = 2 To UBound(a)
      If a(i) > 0 And a(i - 1) > 0 Then
        res(a(i), 1) = arr(a(i - 1), 6)
        res(a(i), 2) = res(a(i), 1) + arr(a(i), 9)
      End If
    Next i
  Next key
  Sheet1.Range("E2").Resize(sRow, 2) = res
End Sub
 
Upvote 0
HieuCD đã viết:
Kiểm tra lại . . .
Mã: 
Sub xyz()
  Dim arr(), res(), a, b, dic As Object, key
  Dim sRow&, i&, tAM As Date

  Set dic = CreateObject("Scripting.Dictionary")
  tAM = 7 / 24 '07:00:00 AM
  arr = Sheet1.Range("A2", Sheet1.Range("I" & Rows.Count).End(xlUp)).Value
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To 2)
  For i = 1 To sRow
    key = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 4)
    If dic.exists(key) = False Then
      ReDim a(1 To arr(i, 3))
    Else
      a = dic(key)
      If arr(i, 3) > UBound(a) Then ReDim Preserve a(1 To arr(i, 3))
    End If
    a(arr(i, 3)) = i
    dic(key) = a
  Next i
  For Each key In dic.keys
    a = dic(key)
    If a(1) > 0 Then
      res(a(1), 1) = arr(a(1), 4) + tAM
      If arr(a(1), 2) = "NS" Then res(a(1), 1) = res(a(1), 1) + 1 / 2
      res(a(1), 2) = res(a(1), 1) + arr(a(1), 9)
    End If
    For i = 2 To UBound(a)
      If a(i) > 0 And a(i - 1) > 0 Then
        res(a(i), 1) = arr(a(i - 1), 6)
        res(a(i), 2) = res(a(i), 1) + arr(a(i), 9)
      End If
    Next i
  Next key
  Sheet1.Range("E2").Resize(sRow, 2) = res
End Sub
Nhấp chuột vào đây để mở rộng...
Code chạy mượt mà quá bạn ơi, thêm nữa là thấy bạn reply lúc 23:33 , cảm ơn bạn rất nhiều.
Chỉ còn 1 cái hạn chế là nếu mình tăng dữ liệu lên khoảng 500 dòng thì nó bị overflow, bạn có thể giúp mình sửa lỗi này dc không?
1717124252172.png
 
Upvote 0
xuannam1911 đã viết:
Code chạy mượt mà quá bạn ơi, thêm nữa là thấy bạn reply lúc 23:33 , cảm ơn bạn rất nhiều.
Chỉ còn 1 cái hạn chế là nếu mình tăng dữ liệu lên khoảng 500 dòng thì nó bị overflow, bạn có thể giúp mình sửa lỗi này dc không?
View attachment 301262
Nhấp chuột vào đây để mở rộng...
Có thể dữ liệu file bạn có gì đó không chuẩn, gởi file bị lỗi để mình kiểm tra
 
Upvote 0
HieuCD đã viết:
Cột C bị lỗi định dang, định dạng lại theo "General" sẽ hết lỗi
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn, như trong file bạn thấy số lần sequence nó có đến 19 lần, vậy mình có thể chạy code cho 19 lần k bạn? và khi mình chạy code thì chỉ có sequence 1 chạy, phải chạy thêm 1 lần nữa để chạy tiếp sequence 2 tương tự cho 3,....
 
Upvote 0
xuannam1911 đã viết:
Cảm ơn bạn, như trong file bạn thấy số lần sequence nó có đến 19 lần, vậy mình có thể chạy code cho 19 lần k bạn? và khi mình chạy code thì chỉ có sequence 1 chạy, phải chạy thêm 1 lần nữa để chạy tiếp sequence 2 tương tự cho 3,....
Nhấp chuột vào đây để mở rộng...
Số lần sequence "không giới hạn"
Theo điều kiện "+ Sequence 3 sẽ bằng end của sequence 2" code xét nếu không có sequence 2 thì sequence 3 bỏ qua và những thằng sau cũng tèo theo
 
Upvote 0
HieuCD đã viết:
Số lần sequence "không giới hạn"
Theo điều kiện "+ Sequence 3 sẽ bằng end của sequence 2" code xét nếu không có sequence 2 thì sequence 3 bỏ qua và những thằng sau cũng tèo theo
Nhấp chuột vào đây để mở rộng...
Mình mới sửa lại đoạn code bị dính lỗi out of range, bạn kiểm tra giúp mình nhé, mình mò từ tối qua đến giờ vẫn k biết tại sao bị.
1717219087574.png
 

File đính kèm

  • edit_plan_V2.xlsm
    331.7 KB · Đọc: 6
Upvote 0
xuannam1911 đã viết:
Mình mới sửa lại đoạn code bị dính lỗi out of range, bạn kiểm tra giúp mình nhé, mình mò từ tối qua đến giờ vẫn k biết tại sao bị.
Nhấp chuột vào đây để mở rộng...

Thử tách dòng màu vàng thành 2 dòng, không viết gộp:

Mã: 
If a(1) > 0 then
       If arr(a(1), 22) < 8 then
                     ......
      End If
End If
 
Upvote 0
Upvote 0
Phuocam đã viết:
Thử tách dòng màu vàng thành 2 dòng, không viết gộp:

Mã: 
If a(1) > 0 then
       If arr(a(1), 22) < 8 then
                     ......
      End If
End If
Nhấp chuột vào đây để mở rộng...
cảm ơn bạn, mình đã fix được rồi
Bài đã được tự động gộp:

HieuCD đã viết:
If a(1) > 0 And arr(a(1), 22) < 8 Then
Dạng nầy không được gộp lại, phải tách ra như hướng dẫn của bạn @Phuocam
Nhấp chuột vào đây để mở rộng...
cảm ơn HieuCD nhé
 
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

D
Xin giúp đỡ: Theo dõi hợp đồng lao động
    • Cười
Trả lời
7
Đọc
185
Denly
D
P
Cách để đoạn appscript tự động chạy cứ mỗi 10 phút
Trả lời
3
Đọc
223
feelingyes
feelingyes
DinhManh1307
Phân loại hình thức sản xuất để tính công
Trả lời
0
Đọc
1
DinhManh1307
DinhManh1307
NGUYENCONGDUNG2
Xin hỗ trợ công thức khách hàng thanh toán giảm công nợ tồn đầu tháng
Trả lời
2
Đọc
32
NGUYENCONGDUNG2
NGUYENCONGDUNG2
NGUYENCONGDUNG2
Hướng dẫn tạo phiếu in xuất khuyến mãi đồng loạt
Trả lời
5
Đọc
55
NGUYENCONGDUNG2
NGUYENCONGDUNG2
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