XD360 KÍNH CHÚC CHO MỌI NHÀ VẠN SỰ AN LÀNH!

Phần mềm ôn thi sát hạch chứng chỉ hành nghề xây dựng

 Quên mật khẩu
 Đăng ký mới
Anh Trần HòeBùi Quốc Hưng
Xem: 765|Trả lời: 1
Thu gọn cột thông tin

[Nhờ sửa giúp] VBA trong excel list hồ sơ hoàn công

[Lấy địa chỉ]
xhxd Đăng lúc 31/12/2022 10:45 | Xem tất |Chế độ đọc

Hãy đăng nhập để có nhiều chức năng hữu dụng hơn và xem ảnh rõ hơn!

Bạn phải đăng nhập để xem được nội dung, nếu bạn chưa có tài khoản? hãy Đăng ký mới

x
Mình thêm cột trong Excel, Giờ VBA trong excel, nhờ mọi người sửa giúp với sheet NK_2
Sub INNK_Days()
  Dim dArr As Variant, sArr As Variant, tArr As Variant, Arr As Variant, S As Variant
  Dim i As Long, k As Long, n As Long, sR As Long, l As Long
  Dim fDay
  Application.ScreenUpdating = False
  With Sheets("DMCV")
    dArr = .Range("E2:AG" & .Range("E65500").End(xlUp).Row).Value2
  End With
  With Sheets("DMVL")
    sArr = .Range("D2:AG" & .Range("E65500").End(xlUp).Row).Value2
  End With
  With Sheets("NK_2")
    fDay = Sheets("NK_2").Range("B1").Value2 ' ngay bat dau
    i = Range("B3").Value2 - fDay + 1
    If i < 1 Then MsgBox ("Xem lai ngay bat dau va ngay ket thuc"): Exit Sub
    ReDim tArr(1 To i, 1 To 5) 'mang ghi nhan cac ngay và thu tu dong du lieu can lay
    'ngay bat dau ghi vào dòng 1 cua tArr
  End With
  For i = 1 To UBound(dArr)
    'ghi nhan dòng "ten cong viec", só 24 = thu tu cot AB - thu tu cot E +1
    If Len(dArr(i, 24)) And Len(dArr(i, 25)) Then
      For n = dArr(i, 24) To dArr(i, 25)
        k = n - fDay + 1
        tArr(k, 2) = tArr(k, 2) & "," & i
      Next n
    End If
    'ghi nhan dòng "nhiem thu", só 19 = thu tu cot W - thu tu cot E +1
    If Len(dArr(i, 19)) Then
      k = dArr(i, 19) - fDay + 1
      tArr(k, 3) = tArr(k, 3) & "," & i
    End If
    'ghi nhan dòng "lay mau TN", só 5 = thu tu cot I - thu tu cot E +1
    If Len(dArr(i, 5)) Then
      k = dArr(i, 5) - fDay + 1
      tArr(k, 4) = tArr(k, 4) & "," & i
    End If
  Next i
   For i = 1 To UBound(sArr)
    'ghi nhan dòng "lay mau VL", só 8 = thu tu cot K - thu tu cot D +1
    If Len(sArr(i, 8)) Then
      k = sArr(i, 8) - fDay + 1
      tArr(k, 5) = tArr(k, 5) & "," & i
    End If
  Next i
   ReDim Arr(1 To 65000, 1 To 7)
  sR = 1
  For i = 1 To UBound(tArr)
    If Len(tArr(i, 2)) + Len(tArr(i, 3)) + Len(tArr(i, 4)) + Len(tArr(i, 5)) Then 'neu có du lieu
    Arr(sR, 1) = fDay + i - 1 'ngay có du lieu
    For n = 2 To 4
      If Len(tArr(i, n)) Then
        k = 0
        S = Split(tArr(i, n), ",")
        Arr(sR, 2) = Sheets("DMCV").Range("C" & S(1) + 1).Value 'hang muc
        ' lay cac cot: "ten cong viec", "nhiem thu", "lay mau TN", "gio nghiem thu"
        For j = 1 To UBound(S)
          If n = 3 Then Arr(sR + k, 7) = dArr(S(j), 21) 'gio nghiem thu, só 21 = thu tu cot Y - thu tu cot E +1
          Arr(sR + k, n + 1) = dArr(S(j), 1)
          k = k + 1
        Next j
      End If
      If tmp < sR + k Then tmp = sR + k
    Next n
    If Len(tArr(i, 5)) Then ' lay cot "lay mau VL"
      k = 0
      S = Split(tArr(i, 5), ",")
      For j = 1 To UBound(S)
        Arr(sR + k, 6) = sArr(S(j), 1)
        k = k + 1 ' dem so dong tung ngay, cua tung cot
      Next j
    End If
    If tmp < sR + k Then tmp = sR + k ' thu tu dong cuoi cua tung ngay
    If sR + 1 = tmp Then sR = tmp + 1 Else sR = tmp ' dieu chinh thu tu dong cuoi cua tung ngay, de cot ngay co it nhat 1 dong trong
    End If
  Next i
   With Sheets("NK_2")
    .Range("A6:G50000").ClearContents
    .Range("A6:G6").Resize(sR) = Arr
  End With
  Application.ScreenUpdating = True
End Sub
Sub Spinner_Change()
  Dim dArr As Variant, sArr As Variant
  Dim i As Long, k1 As Byte, k2 As Byte, k3 As Byte, k4 As Byte, k5 As Byte
  Dim R1 As Byte, R2 As Byte, R3 As Byte, R4 As Byte, R5 As Byte
  Dim ngay
  Application.ScreenUpdating = False
  R1 = 16: R2 = 44: R3 = 63: R4 = 82: R5 = 103
  ngay = Range("B5").Value2
  Rows("16:122").EntireRow.Hidden = False
  Union(Range("A16:A42"), Range("A44:A61"), Range("A63:A80"), Range("A82:A101"), Range("A103:A122")).ClearContents
  With Sheets("DMCV")
    dArr = .Range("E2:AG" & .Range("E65500").End(xlUp).Row).Value2
  End With
  With Sheets("DMVL")
    sArr = .Range("D2:AG" & .Range("E65500").End(xlUp).Row).Value2
  End With
  For i = 1 To UBound(dArr)
    If Len(dArr(i, 24)) And Len(dArr(i, 25)) Then
      If dArr(i, 24) <= ngay And dArr(i, 25) >= ngay Then
        Cells(R1 + k1, 1) = dArr(i, 1)
        k1 = k1 + 1
      End If
    End If
    If dArr(i, 19) = ngay Then
      Cells(R2 + k2, 1) = dArr(i, 1)
      k2 = k2 + 1
    End If
    If dArr(i, 5) = ngay Then
      Cells(R3 + k3, 1) = dArr(i, 1)
      k3 = k3 + 1
    End If
  Next i
  If k1 + R1 <= 42 Then Rows(k1 + R1 & ":39").EntireRow.Hidden = True
  If k2 + R2 <= 61 Then Rows(k2 + R2 & ":58").EntireRow.Hidden = True
  If k3 + R3 <= 80 Then Rows(k3 + R3 & ":77").EntireRow.Hidden = True
    For i = 1 To UBound(sArr)
    If sArr(i, 8) = ngay Then
      Cells(R4 + k4, 1) = sArr(i, 1)
      k4 = k4 + 1
    End If
    If sArr(i, 20) = ngay Then
      Cells(R5 + k5, 1) = sArr(i, 1)
      k5 = k5 + 1
    End If
      Next i
  If k4 + R4 <= 101 Then Rows(k4 + R4 & ":98").EntireRow.Hidden = True
If k5 + R5 <= 122 Then Rows(k5 + R5 & ":119").EntireRow.Hidden = True
  Application.ScreenUpdating = True
End Sub

www.xaydung360.vn XÂY TÂM, DỰNG TẦM CHUYÊN NGHIỆP

tranhoe Đăng lúc 31/12/2022 12:48 | Xem tất
1./ Đã sửa tiêu đề giúp Bạn. Lần sau: bài sẽ bị Xóa theo nội quy, ở đây
2./ Đưa file lên mới sửa được. Không mua Trâu vẽ Bóng.

www.xaydung360.vn XÂY TÂM, DỰNG TẦM CHUYÊN NGHIỆP

Phiên bản Mobile|Phần mềm ôn thi sát hạch chứng chỉ hành nghề xây dựng  

Phần mềm dự toán xây dựng excel | Hướng dẫn lập dự toán xây dựng | Phần mềm tư vấn giám sát | Phần mềm quản lý chất lượng xây dựng |

Phần mềm ôn thi sát hạch chứng chỉ hành nghề xây dựng

Phần mềm ôn thi sát hạch chứng chỉ hành nghề Kiến Trúc sư

Phần mềm ôn thi sát hạch chứng chỉ hành nghề Đấu thầu

GMT+7, 29/3/2024 04:23 , Processed in 0.121050 second(s), 22 queries .

Powered by Discuz! X3.2

© 2001-2013 Kiso Comsenz Inc.