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 (1 người xem)

xuannam1911 · 30/5/24

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!

HieuCD · 30/5/24

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

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

xuannam1911 · 31/5/24

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

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?

HieuCD · 31/5/24

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

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

xuannam1911 · 31/5/24

HieuCD đã viết:
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

File đây bạn ơi, mình đã đưa đoạn code vào file chính và đã chỉnh sửa lại, bạn kiểm tra giúp mình nhé

HieuCD · 31/5/24

xuannam1911 đã viết:
File đây bạn ơi, mình đã đưa đoạn code vào file chính và đã chỉnh sửa lại, bạn kiểm tra giúp mình nhé

Cột C bị lỗi định dang, định dạng lại theo "General" sẽ hết lỗi

xuannam1911 · 31/5/24

HieuCD đã viết:
Cột C bị lỗi định dang, định dạng lại theo "General" sẽ hết lỗi

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,....

HieuCD · 31/5/24

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,....

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

xuannam1911 · 31/5/24

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

Mình đã hiểu, cảm ơn bạn rất nhiều nhé.

xuannam1911 · 1/6/24

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

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ị.

Phuocam · 1/6/24

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ị.

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

HieuCD · 1/6/24

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ị.
View attachment 301297

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

xuannam1911 · 1/6/24

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

cảm ơn bạn, mình đã fix được rồi

Bài đã được tự động gộp: 1/6/24

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

cảm ơn HieuCD nhé

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 (1 người xem)

Người dùng đang xem chủ đề này

xuannam1911

Thành viên mới

File đính kèm

HieuCD

Chuyên gia GPE

xuannam1911

Thành viên mới

HieuCD

Chuyên gia GPE

xuannam1911

Thành viên mới

File đính kèm

HieuCD

Chuyên gia GPE

xuannam1911

Thành viên mới

HieuCD

Chuyên gia GPE

xuannam1911

Thành viên mới

xuannam1911

Thành viên mới

File đính kèm

Phuocam

Thành viên mới

HieuCD

Chuyên gia GPE

xuannam1911

Thành viên mới

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

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

Đếm ngược thời gian