Thống kê ngày nghỉ (có định dạng tô nền màu đỏ)

Liên hệ QC
Q

QuangMinhtb

Thành viên hoạt động
Tham gia
31/10/19
Bài viết
171
Được thích
34
Xin chào các anh/chị và các bạn.
Trong Sheet(Danh muc NT cong viec) tìm tất cả dữ liệu có định dạng là ngày/tháng/năm trong tất cả các cột có dữ liệu định dạng ngày/tháng/năm. dữ liệu này được tô nền đỏ và được lấy sang để điền vào cột C trong Sheet (C_Ngay Nghi) và được sắp xếp theo thứ tự ngày tăng dần.
Các ngày trùng nhau chỉ được tính lấy 1 lần để điền sang sheet (C_Ngay Nghi)
Em xin được các anh/chị và các bạn giúp em bài toán này
Em xin cảm ơn!
ad.pngae.png
 

File đính kèm

  • Code.xlsx
    57.6 KB · Đọc: 16
Chạy code
Mã: 
Sub ABC()
  Dim rng As Range, arr() As Boolean, Res()
  Dim sRow&, sCol&, i&, j&, k&, dMax&
  Const colorID& = 3 'Mau Do, ma mau ngay nghi
 
  With Sheets("Danh muc NT cong viec")
    Set rng = .Range("V10:AI" & .Range("G" & Rows.Count).End(xlUp).Row)
  End With
  sRow = rng.Rows.Count: sCol = rng.Columns.Count
  For i = 1 To sRow
    For j = 1 To sCol
      If rng(i, j).Interior.ColorIndex = colorID Then
        If IsDate(rng(i, j).Value) Then
          If dMax < CLng(rng(i, j).Value) Then
            dMax = CLng(rng(i, j).Value)
            ReDim Preserve arr(36526 To dMax) '1/1/2000 toi Ngay lon nhat
          End If
          arr(rng(i, j).Value) = True
          k = k + 1
        End If
      End If
    Next j
  Next i
  ReDim Res(1 To k, 1 To 2)
  k = 0
  For i = 36526 To dMax
    If arr(i) = True Then
      k = k + 1
      Res(k, 1) = k
      Res(k, 2) = CDate(i)
    End If
  Next i
  With Sheets("C_Ngay Nghi")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 3 Then .Range("B4:C" & i).ClearContents
    If k Then .Range("B4").Resize(k, 2) = Res
  End With
End Sub
 
HieuCD đã viết:
Chạy code
Mã: 
Sub ABC()
  Dim rng As Range, arr() As Boolean, Res()
  Dim sRow&, sCol&, i&, j&, k&, dMax&
  Const colorID& = 3 'Mau Do, ma mau ngay nghi
 
  With Sheets("Danh muc NT cong viec")
    Set rng = .Range("V10:AI" & .Range("G" & Rows.Count).End(xlUp).Row)
  End With
  sRow = rng.Rows.Count: sCol = rng.Columns.Count
  For i = 1 To sRow
    For j = 1 To sCol
      If rng(i, j).Interior.ColorIndex = colorID Then
        If IsDate(rng(i, j).Value) Then
          If dMax < CLng(rng(i, j).Value) Then
            dMax = CLng(rng(i, j).Value)
            ReDim Preserve arr(36526 To dMax) '1/1/2000 toi Ngay lon nhat
          End If
          arr(rng(i, j).Value) = True
          k = k + 1
        End If
      End If
    Next j
  Next i
  ReDim Res(1 To k, 1 To 2)
  k = 0
  For i = 36526 To dMax
    If arr(i) = True Then
      k = k + 1
      Res(k, 1) = k
      Res(k, 2) = CDate(i)
    End If
  Next i
  With Sheets("C_Ngay Nghi")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 3 Then .Range("B4:C" & i).ClearContents
    If k Then .Range("B4").Resize(k, 2) = Res
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ! em cảm ơn anh rất nhiều.
Chúc anh ngày mới nhiều niềm vui
 
HieuCD đã viết:
Chạy code
Mã: 
Sub ABC()
  Dim rng As Range, arr() As Boolean, Res()
  Dim sRow&, sCol&, i&, j&, k&, dMax&
  Const colorID& = 3 'Mau Do, ma mau ngay nghi
 
  With Sheets("Danh muc NT cong viec")
    Set rng = .Range("V10:AI" & .Range("G" & Rows.Count).End(xlUp).Row)
  End With
  sRow = rng.Rows.Count: sCol = rng.Columns.Count
  For i = 1 To sRow
    For j = 1 To sCol
      If rng(i, j).Interior.ColorIndex = colorID Then
        If IsDate(rng(i, j).Value) Then
          If dMax < CLng(rng(i, j).Value) Then
            dMax = CLng(rng(i, j).Value)
            ReDim Preserve arr(36526 To dMax) '1/1/2000 toi Ngay lon nhat
          End If
          arr(rng(i, j).Value) = True
          k = k + 1
        End If
      End If
    Next j
  Next i
  ReDim Res(1 To k, 1 To 2)
  k = 0
  For i = 36526 To dMax
    If arr(i) = True Then
      k = k + 1
      Res(k, 1) = k
      Res(k, 2) = CDate(i)
    End If
  Next i
  With Sheets("C_Ngay Nghi")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 3 Then .Range("B4:C" & i).ClearContents
    If k Then .Range("B4").Resize(k, 2) = Res
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Anh ơi, xin nhờ anh bớt chút thời gian giúp em chút nữa:
Em có thêm một Sheet (Danh muc NT vat lieu)
Anh giúp em thống kê thêm ngày nghỉ (tô nền đỏ) từ Sheet này để điền vào Sheet (C_Ngay Nghi) với ạ!
Nghia là điền ngày nghỉ từ cả 2 sheet (Danh muc NT Cong viec) và Sheet (Danh muc VT vat lieu) vào sheet (C_Ngay Nghi)
Xin được anh giúp em nốt lần này!
Em cảm ơn anh!
them.png
 

File đính kèm

  • Code_them.xlsx
    107.6 KB · Đọc: 9
Lần chỉnh sửa cuối:
QuangMinhtb đã viết:
Anh ơi, xin nhờ anh bớt chút thời gian giúp em chút nữa:
Em có thêm một Sheet (Danh muc NT vat lieu)
Anh giúp em thống kê ngày nghỉ (tô nền đỏ) từ Sheet này để điền vào Sheet (C_Ngay Nghi) với ạ!
Xin được anh giúp em nốt lần này!
Em cảm ơn anh!
View attachment 261600
Nhấp chuột vào đây để mở rộng...
Chỉnh sửa lại cái vùng dữ liệu trong code thôi ban.
 

File đính kèm

  • Code_them.xlsm
    116.2 KB · Đọc: 14
Fatboy_nnha đã viết:
Chỉnh sửa lại cái vùng dữ liệu trong code thôi ban.
Nhấp chuột vào đây để mở rộng...

Fatboy_nnha đã viết:
Chỉnh sửa lại cái vùng dữ liệu trong code thôi ban.
Nhấp chuột vào đây để mở rộng...
Mình cảm ơn bạn nhé!
Ý mình muốn điền ngày nghỉ ( định dạng tô nền đỏ) từ cả 2 sheet (Danh muc NT vat lieu) và Sheet (Danh muc NT cong viec) vào sheet (C_Ngay nghi)
Mình chạy code thấy chưa được.
Cảm ơn bạn!
 
QuangMinhtb đã viết:
điền ngày nghỉ ( định dạng tô nền đỏ) từ cả 2 sheet (Danh muc NT vat lieu) và Sheet (Danh muc NT cong viec) vào sheet (C_Ngay nghi)
Nhấp chuột vào đây để mở rộng...
Mượn code của Fatboy_nnha sửa lại tí, bạn xem thử thế nào
Rich (BB code): 
Sub ABC()
  Dim rng As Range, arr() As Boolean, Res() As Variant
  Dim sRow&, sCol&, i&, j&, k&, dMax&
  Const colorID& = 3 'Mau Do, ma mau ngay nghi
 
 ReDim Res(1 To 500, 1 To 2)
  With Sheets("Danh muc NT vat lieu")
    Set rng = .Range("J10:U" & .Range("J" & Rows.Count).End(xlUp).Row)
  End With
  sRow = rng.Rows.Count: sCol = rng.Columns.Count
  For i = 1 To sRow
    For j = 1 To sCol
      If rng(i, j).Interior.ColorIndex = colorID Then
        If IsDate(rng(i, j).Value) Then
          k = k + 1
          Res(k, 1) = k
          Res(k, 2) = rng(i, j).Value
        End If
      End If
    Next j
  Next i
  With Sheets("Danh muc NT cong viec")
    Set rng = .Range("V10:AJ" & .Range("V" & Rows.Count).End(xlUp).Row)
  End With
  sRow = rng.Rows.Count: sCol = rng.Columns.Count
  For i = 1 To sRow
    For j = 1 To sCol
      If rng(i, j).Interior.ColorIndex = colorID Then
        If IsDate(rng(i, j).Value) Then
          k = k + 1
          Res(k, 1) = k
          Res(k, 2) = rng(i, j).Value
        End If
      End If
    Next j
  Next i
  With Sheets("C_Ngay Nghi")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 3 Then .Range("B4:C" & i).ClearContents
    If k Then
        .Range("B4").Resize(k, 2) = Res
        .Range("C4").Resize(k, 1).Sort Key1:=Range("C4"), Order1:=xlAscending, Header:=xlNo, DataOption1:=xlSortTextAsNumbers
    End If
  End With
End Sub
 
Maika8008 đã viết:
Mượn code của Fatboy_nnha sửa lại tí, bạn xem thử thế nào
Rich (BB code): 
Sub ABC()
  Dim rng As Range, arr() As Boolean, Res() As Variant
  Dim sRow&, sCol&, i&, j&, k&, dMax&
  Const colorID& = 3 'Mau Do, ma mau ngay nghi
 
 ReDim Res(1 To 500, 1 To 2)
  With Sheets("Danh muc NT vat lieu")
    Set rng = .Range("J10:U" & .Range("J" & Rows.Count).End(xlUp).Row)
  End With
  sRow = rng.Rows.Count: sCol = rng.Columns.Count
  For i = 1 To sRow
    For j = 1 To sCol
      If rng(i, j).Interior.ColorIndex = colorID Then
        If IsDate(rng(i, j).Value) Then
          k = k + 1
          Res(k, 1) = k
          Res(k, 2) = rng(i, j).Value
        End If
      End If
    Next j
  Next i
  With Sheets("Danh muc NT cong viec")
    Set rng = .Range("V10:AJ" & .Range("V" & Rows.Count).End(xlUp).Row)
  End With
  sRow = rng.Rows.Count: sCol = rng.Columns.Count
  For i = 1 To sRow
    For j = 1 To sCol
      If rng(i, j).Interior.ColorIndex = colorID Then
        If IsDate(rng(i, j).Value) Then
          k = k + 1
          Res(k, 1) = k
          Res(k, 2) = rng(i, j).Value
        End If
      End If
    Next j
  Next i
  With Sheets("C_Ngay Nghi")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 3 Then .Range("B4:C" & i).ClearContents
    If k Then
        .Range("B4").Resize(k, 2) = Res
        .Range("C4").Resize(k, 1).Sort Key1:=Range("C4"), Order1:=xlAscending, Header:=xlNo, DataOption1:=xlSortTextAsNumbers
    End If
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Rất cảm ơn anh Maika8008 :throb:
 
Maika8008 đã viết:
Mượn code của Fatboy_nnha sửa lại tí, bạn xem thử thế nào
Rich (BB code): 
Sub ABC()
  Dim rng As Range, arr() As Boolean, Res() As Variant
  Dim sRow&, sCol&, i&, j&, k&, dMax&
  Const colorID& = 3 'Mau Do, ma mau ngay nghi
 
 ReDim Res(1 To 500, 1 To 2)
  With Sheets("Danh muc NT vat lieu")
    Set rng = .Range("J10:U" & .Range("J" & Rows.Count).End(xlUp).Row)
  End With
  sRow = rng.Rows.Count: sCol = rng.Columns.Count
  For i = 1 To sRow
    For j = 1 To sCol
      If rng(i, j).Interior.ColorIndex = colorID Then
        If IsDate(rng(i, j).Value) Then
          k = k + 1
          Res(k, 1) = k
          Res(k, 2) = rng(i, j).Value
        End If
      End If
    Next j
  Next i
  With Sheets("Danh muc NT cong viec")
    Set rng = .Range("V10:AJ" & .Range("V" & Rows.Count).End(xlUp).Row)
  End With
  sRow = rng.Rows.Count: sCol = rng.Columns.Count
  For i = 1 To sRow
    For j = 1 To sCol
      If rng(i, j).Interior.ColorIndex = colorID Then
        If IsDate(rng(i, j).Value) Then
          k = k + 1
          Res(k, 1) = k
          Res(k, 2) = rng(i, j).Value
        End If
      End If
    Next j
  Next i
  With Sheets("C_Ngay Nghi")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 3 Then .Range("B4:C" & i).ClearContents
    If k Then
        .Range("B4").Resize(k, 2) = Res
        .Range("C4").Resize(k, 1).Sort Key1:=Range("C4"), Order1:=xlAscending, Header:=xlNo, DataOption1:=xlSortTextAsNumbers
    End If
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Em chào anh, xin được làm phiền anh chút xíu.
Em có chạy thử file a giúp,
Thấy báo như hình.
Nhờ anh xem giúp em xíu.
loi.png
 

File đính kèm

  • File maikaka_giup.xlsm
    181.6 KB · Đọc: 3
Dữ liệu trong file ví dụ hay dữ liệu khác? Tôi dùng file bài 5
 
Lần chỉnh sửa cuối:
Nếu vậy thì tôi cũng không hiểu tại sao vì tôi đã chạy thử rồi, có vấn đề gì đâu. Bạn có thể bấm Debug rồi xem biến k lúc đó có giá trị bằng bao nhiêu?
 

File đính kèm

  • Code_them (7).xlsm
    180.7 KB · Đọc: 6
QuangMinhtb đã viết:
Em có tải file và video, nhờ anh xem giiúp:
Liên kết: https://www.youtube.com/watch?v=gFgxUFfCLV8
Nhấp chuột vào đây để mở rộng...
Chỉnh code
Mã: 
Sub ABC()
  Dim aRng(1 To 2) As Range, rng, cel As Range, arr() As Boolean, Res(), i&, k&, dMax&
  Const colorID& = 3 'Mau Do, ma mau ngay nghi
 
  With Sheets("Danh muc NT cong viec")
    Set aRng(1) = .Range("V10:AI" & .Range("G" & Rows.Count).End(xlUp).Row)
  End With
  With Sheets("Danh muc NT vat lieu")
    Set aRng(2) = .Range("J10:T" & .Range("E" & Rows.Count).End(xlUp).Row)
  End With
  For Each rng In aRng
    For Each cel In rng
      If cel.Interior.ColorIndex = colorID Then
        If IsDate(cel.Value) Then
          If dMax < CLng(cel.Value) Then
            dMax = CLng(cel.Value)
            ReDim Preserve arr(36526 To dMax) '1/1/2000 toi Ngay lon nhat
          End If
          arr(cel.Value) = True
          k = k + 1
        End If
      End If
    Next cel
  Next
  ReDim Res(1 To k, 1 To 2)
  k = 0
  For i = 36526 To dMax
    If arr(i) = True Then
      k = k + 1
      Res(k, 1) = k
      Res(k, 2) = CDate(i)
    End If
  Next i
  With Sheets("C_Ngay Nghi")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 3 Then .Range("B4:C" & i).ClearContents
    If k Then .Range("B4").Resize(k, 2) = Res
  End With
End Sub
 
HieuCD đã viết:
Chỉnh code
Mã: 
Sub ABC()
  Dim aRng(1 To 2) As Range, rng, cel As Range, arr() As Boolean, Res(), i&, k&, dMax&
  Const colorID& = 3 'Mau Do, ma mau ngay nghi
 
  With Sheets("Danh muc NT cong viec")
    Set aRng(1) = .Range("V10:AI" & .Range("G" & Rows.Count).End(xlUp).Row)
  End With
  With Sheets("Danh muc NT vat lieu")
    Set aRng(2) = .Range("J10:T" & .Range("E" & Rows.Count).End(xlUp).Row)
  End With
  For Each rng In aRng
    For Each cel In rng
      If cel.Interior.ColorIndex = colorID Then
        If IsDate(cel.Value) Then
          If dMax < CLng(cel.Value) Then
            dMax = CLng(cel.Value)
            ReDim Preserve arr(36526 To dMax) '1/1/2000 toi Ngay lon nhat
          End If
          arr(cel.Value) = True
          k = k + 1
        End If
      End If
    Next cel
  Next
  ReDim Res(1 To k, 1 To 2)
  k = 0
  For i = 36526 To dMax
    If arr(i) = True Then
      k = k + 1
      Res(k, 1) = k
      Res(k, 2) = CDate(i)
    End If
  Next i
  With Sheets("C_Ngay Nghi")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 3 Then .Range("B4:C" & i).ClearContents
    If k Then .Range("B4").Resize(k, 2) = Res
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
a Hiếu luôn hết mình giúp đỡ mọi người, em rất khâm phục anh.
 
HieuCD đã viết:
Chỉnh code
Mã: 
Sub ABC()
  Dim aRng(1 To 2) As Range, rng, cel As Range, arr() As Boolean, Res(), i&, k&, dMax&
  Const colorID& = 3 'Mau Do, ma mau ngay nghi
 
  With Sheets("Danh muc NT cong viec")
    Set aRng(1) = .Range("V10:AI" & .Range("G" & Rows.Count).End(xlUp).Row)
  End With
  With Sheets("Danh muc NT vat lieu")
    Set aRng(2) = .Range("J10:T" & .Range("E" & Rows.Count).End(xlUp).Row)
  End With
  For Each rng In aRng
    For Each cel In rng
      If cel.Interior.ColorIndex = colorID Then
        If IsDate(cel.Value) Then
          If dMax < CLng(cel.Value) Then
            dMax = CLng(cel.Value)
            ReDim Preserve arr(36526 To dMax) '1/1/2000 toi Ngay lon nhat
          End If
          arr(cel.Value) = True
          k = k + 1
        End If
      End If
    Next cel
  Next
  ReDim Res(1 To k, 1 To 2)
  k = 0
  For i = 36526 To dMax
    If arr(i) = True Then
      k = k + 1
      Res(k, 1) = k
      Res(k, 2) = CDate(i)
    End If
  Next i
  With Sheets("C_Ngay Nghi")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 3 Then .Range("B4:C" & i).ClearContents
    If k Then .Range("B4").Resize(k, 2) = Res
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Anh ơi, em coppy code vào file tương tự chạy code thấy lỗi, khi xóa sheet khác đi thì không lỗi, do đâu vậy anh?
Em cảm ơn anh!

Tuong Tac.png
 
Lần chỉnh sửa cuối:
Do không có ngày nghỉ, chỉnh lại code
Mã: 
Sub Lay_Ngaynghi()
'Phim tat (Ctrl+CAPSLOCK)
  Dim aRng(1 To 2) As Range, rng, cel As Range, arr() As Boolean, Res(), i&, k&, dMax&
  Const colorID& = 3 'Mau Do, ma mau ngay nghi
 
  With Sheets("Danh muc NT cong viec")
    Set aRng(1) = .Range("V10:AI" & .Range("G" & Rows.Count).End(xlUp).Row)
  End With
  With Sheets("Danh muc NT vat lieu")
    Set aRng(2) = .Range("J10:T" & .Range("E" & Rows.Count).End(xlUp).Row)
  End With
  For Each rng In aRng
    For Each cel In rng
      If cel.Interior.ColorIndex = colorID Then
        If IsDate(cel.Value) Then
          If dMax < CLng(cel.Value) Then
            dMax = CLng(cel.Value)
            ReDim Preserve arr(36526 To dMax) '1/1/2000 toi Ngay lon nhat
          End If
          arr(cel.Value) = True
          k = k + 1
        End If
      End If
    Next cel
  Next
  If k Then
    ReDim Res(1 To k, 1 To 2)
    k = 0
    For i = 36526 To dMax
      If arr(i) = True Then
        k = k + 1
        Res(k, 1) = k
        Res(k, 2) = CDate(i)
      End If
    Next i
    With Sheets("C_Ngay Nghi")
      i = .Range("B" & Rows.Count).End(xlUp).Row
      If i > 3 Then .Range("B4:C" & i).ClearContents
      .Range("B4").Resize(k, 2) = Res
    End With
  Else
    MsgBox "Khong co ngay nghi!"
  End If
End Sub
 
HieuCD đã viết:
Do không có ngày nghỉ, chỉnh lại code
Mã: 
Sub Lay_Ngaynghi()
'Phim tat (Ctrl+CAPSLOCK)
  Dim aRng(1 To 2) As Range, rng, cel As Range, arr() As Boolean, Res(), i&, k&, dMax&
  Const colorID& = 3 'Mau Do, ma mau ngay nghi
 
  With Sheets("Danh muc NT cong viec")
    Set aRng(1) = .Range("V10:AI" & .Range("G" & Rows.Count).End(xlUp).Row)
  End With
  With Sheets("Danh muc NT vat lieu")
    Set aRng(2) = .Range("J10:T" & .Range("E" & Rows.Count).End(xlUp).Row)
  End With
  For Each rng In aRng
    For Each cel In rng
      If cel.Interior.ColorIndex = colorID Then
        If IsDate(cel.Value) Then
          If dMax < CLng(cel.Value) Then
            dMax = CLng(cel.Value)
            ReDim Preserve arr(36526 To dMax) '1/1/2000 toi Ngay lon nhat
          End If
          arr(cel.Value) = True
          k = k + 1
        End If
      End If
    Next cel
  Next
  If k Then
    ReDim Res(1 To k, 1 To 2)
    k = 0
    For i = 36526 To dMax
      If arr(i) = True Then
        k = k + 1
        Res(k, 1) = k
        Res(k, 2) = CDate(i)
      End If
    Next i
    With Sheets("C_Ngay Nghi")
      i = .Range("B" & Rows.Count).End(xlUp).Row
      If i > 3 Then .Range("B4:C" & i).ClearContents
      .Range("B4").Resize(k, 2) = Res
    End With
  Else
    MsgBox "Khong co ngay nghi!"
  End If
End Sub
Nhấp chuột vào đây để mở rộng...
Vâng, xin chân thành cảm ơn anh.
 
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

Salem999999999
Lọc dữ liệu có điều kiện
2
Trả lời
25
Đọc
523
tle2003
T
vuongnlks
Lấy dữ liệu 1 cột cụ thể theo ngày từ nhiều file CSV ứng với mã tương ứng trong cột MA CO PHIEU
Trả lời
1
Đọc
67
BuiQuangThuan
B
V
Hỗ trợ hàm Sumproduct và Subtotal trong GG Sheets
Trả lời
3
Đọc
224
nguyenngocphuongsw
nguyenngocphuongsw
son0611excel
  • Question
VBA tra cứu hình theo điều kiện
Trả lời
10
Đọc
203
tle2003
T
K
Tính tổng có điều kiện
Trả lời
4
Đọc
154
kimson_nb
K
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