Nhờ hỗ trợ lọc trùng về thời gian

Liên hệ QC
Oh sr bạn, đã hiểu vì sao rồi, không được để trống cột stt. Hi. Cám ơn bạn nhiều, mình đã dùng được rồi. :)
 
HieuCD đã viết:
Chạy code
Nhấp chuột vào đây để mở rộng...
Bạn ơi chỉnh lại giúp mình chỗ cột "Tổng thời gian chạy máy trong ngày" với, nó là giá trị tổng thời gian của tất cả các dòng trong ngày đó, chứ không phải giá trị thời gian của riêng dòng đó à. Mình làm tay như trong file để bạn hiểu ý mình hơn. Bạn xem lại giúp mình nhé.
 

File đính kèm

tangoctuan đã viết:
Bạn ơi chỉnh lại giúp mình chỗ cột "Tổng thời gian chạy máy trong ngày" với, nó là giá trị tổng thời gian của tất cả các dòng trong ngày đó, chứ không phải giá trị thời gian của riêng dòng đó à. Mình làm tay như trong file để bạn hiểu ý mình hơn. Bạn xem lại giúp mình nhé.
Nhấp chuột vào đây để mở rộng...
Trong ngày chạy máy bị trùng thời gian, công hết hay loại trùng?
 
tangoctuan đã viết:
Với ngày chạy máy bị trùng thời gian thì vẫn cộng lại hết bạn à.
Nhấp chuột vào đây để mở rộng...
Chỉnh code
Mã: 
Sub ThuTu()
  Dim sArr(), Res(), Arr(), Arr2(), S, Dic As Object, iKey$
  Dim eRow&, sRow&, i&, r&, d As Double
  Dim May$, fTime, eTime, fDate&, eDate&
 
  With Sheets("Sheet4")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow < 3 Then MsgBox ("Khong co du lieu"): Exit Sub
    Application.ScreenUpdating = False
    .Range("A2:D" & eRow).Sort .[B2], 1, .[C2], , 1, Header:=xlYes
    sArr = .Range("B2:D" & eRow).Value
  End With
  sRow = UBound(sArr)
  Set Dic = CreateObject("scripting.dictionary")
  ReDim Res(2 To sRow, 1 To 2)
 
  For i = 2 To sRow
    May = sArr(i, 1)
    fDate = DateValue(sArr(i, 2)):    eDate = DateValue(sArr(i, 3))
    If eDate >= fDate Then
      ReDim Arr(fDate To eDate)
      ReDim Arr2(fDate To eDate)
      For r = fDate To eDate
        If r > fDate Then fTime = r Else fTime = sArr(i, 2)
        If r < eDate Then eTime = r + 1 Else eTime = sArr(i, 3)
        d = Round((eTime - fTime) * 1440, 2)
        iKey = sArr(i, 1) & "#" & r
        If Dic.exists(iKey) = False Then
          Dic.Add iKey, Array(1, d)
        Else
          S = Dic.Item(iKey)
          S(0) = S(0) + 1
          S(1) = S(1) + d
          Dic.Item(iKey) = S
        End If
        If fDate = eDate Then
          Arr(r) = Dic.Item(iKey)(0)
          Arr2(r) = iKey
        Else
          Arr(r) = Dic.Item(iKey)(0) & " (" & Format(r, "dd/mm") & ")"
          Arr2(r) = iKey & " (" & Format(r, "dd/mm") & ")"
        End If
      Next r
      Res(i, 1) = Join(Arr, "; ")
      Res(i, 2) = Join(Arr2, "; ")
    End If
  Next i
 
  For i = 2 To sRow
    fDate = DateValue(sArr(i, 2)):    eDate = DateValue(sArr(i, 3))
    If eDate >= fDate Then
      For r = fDate To eDate
        iKey = sArr(i, 1) & "#" & r
        Res(i, 2) = Replace(Res(i, 2), iKey, Dic.Item(iKey)(1))
      Next r
    End If
  Next i
 
  With Sheets("Sheet4")
    .Range("E3").Resize(sRow - 1, 2) = Res
    .Range("A2:F" & eRow).Sort .[A2], 1, Header:=xlYes
  End With
  Application.ScreenUpdating = True
End Sub
 
HieuCD đã viết:
Chỉnh code
Nhấp chuột vào đây để mở rộng...
Bạn ơi cho mình hỏi chút, mình chạy vba ra kết quả như file đính kèm. Kết quả ô P10701 lớn hơn rất nhiều so với kết quả ở ô Q10701 (mà đúng ra phải tương đương, kết quả cột P với các giá trị thấp đều rất chuẩn so với cột Q tương ứng). Nhờ bạn xem hộ vì sao với? Mình đang suy đoán có phải do 1 cell bị giới hạn ký tự nên không list được hết không nhỉ?
 

File đính kèm

tangoctuan đã viết:
Bạn ơi cho mình hỏi chút, mình chạy vba ra kết quả như file đính kèm. Kết quả ô P10701 lớn hơn rất nhiều so với kết quả ở ô Q10701 (mà đúng ra phải tương đương, kết quả cột P với các giá trị thấp đều rất chuẩn so với cột Q tương ứng). Nhờ bạn xem hộ vì sao với? Mình đang suy đoán có phải do 1 cell bị giới hạn ký tự nên không list được hết không nhỉ?
Nhấp chuột vào đây để mở rộng...
Trong code có lệnh
If Len(Res(i, j + 1)) < 250 Then Res(i, j + 1) = Res(i, j + 1) & ", " & sArr(r, 1) 'Gioi han so ky tu ket qua
Nếu số ký tự quá lớn khi gán mảng kết quả lên sheet sẽ bị lổi, nếu muốn lấy hết ký tự phải gán từng range, code sẽ chạy chậm
 
HieuCD đã viết:
Chỉnh code
Nhấp chuột vào đây để mở rộng...
Nhờ bạn xem hộ thêm 1 vấn đề này nữa với, cùng vba đó, mình chạy cho 2 tập data: 1 tập 49k dòng, 1 tập 11k dòng (nằm trong (thuộc) tập 49k dòng) => Thì kết quả trả về ở cột P ở mỗi file lại khác nhau? Trong khi đúng ra nó phải như nhau vì thuật toán check ở cột P chỉ phụ thuộc vào cột B (khi cùng giá trị ở cột B thì mới xét "khác trạm, khác máy"). File 11k là tập con của file 49k nên cột P đối với cùng 1 STT phải như nhau.
Trong file đính kèm mình filter sẵn ví dụ 1 STT bị như thế. Vậy rất mong bạn xem giúp mình là bị sao với?
 

File đính kèm

tangoctuan đã viết:
Nhờ bạn xem hộ thêm 1 vấn đề này nữa với, cùng vba đó, mình chạy cho 2 tập data: 1 tập 49k dòng, 1 tập 11k dòng (nằm trong (thuộc) tập 49k dòng) => Thì kết quả trả về ở cột P ở mỗi file lại khác nhau? Trong khi đúng ra nó phải như nhau vì thuật toán check ở cột P chỉ phụ thuộc vào cột B (khi cùng giá trị ở cột B thì mới xét "khác trạm, khác máy"). File 11k là tập con của file 49k nên cột P đối với cùng 1 STT phải như nhau.
Trong file đính kèm mình filter sẵn ví dụ 1 STT bị như thế. Vậy rất mong bạn xem giúp mình là bị sao với?
Nhấp chuột vào đây để mở rộng...
Code nhầm vị trí lệnh Exit for
Mã: 
Sub XetTrung()
  Dim sArr(), Res()
  Dim eRow&, sRow&, j&, i&, r&, tmp$, d As Double
  Dim stt&, kVuc$, Tram$, May$, fTime, eTime

  Application.ScreenUpdating = False
  With Sheets("Check")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow < 3 Then MsgBox ("Khong co du lieu"): Exit Sub
    .Range("A2:R" & eRow).Sort .[E2], 1, Header:=xlYes
    sArr = .Range("A3:F" & eRow).Value
  End With
  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To 12)
  For i = 1 To sRow - 1
    stt = sArr(i, 1):    kVuc = sArr(i, 2):    Tram = sArr(i, 3)
    May = sArr(i, 4):   fTime = sArr(i, 5):     eTime = sArr(i, 6)
    If fTime < eTime Then
      For r = i + 1 To sRow
        If sArr(r, 5) < eTime Then
          If sArr(r, 5) < sArr(r, 6) Then
            If sArr(r, 3) = Tram Then j = 1 Else j = 7
            If sArr(r, 4) <> May Then j = j + 3
            If sArr(r, 2) = kVuc Or j <> 10 Then
              Res(i, j) = Res(i, j) + 1
              Res(r, j) = Res(r, j) + 1
              If Len(Res(i, j + 1)) Then
                If Len(Res(i, j + 1)) < 250 Then Res(i, j + 1) = Res(i, j + 1) & ", " & sArr(r, 1) 'Gioi han so ky tu ket qua
              Else
                Res(i, j + 1) = sArr(r, 1)
              End If
              If Len(Res(r, j + 1)) Then
                If Len(Res(r, j + 1)) < 250 Then Res(r, j + 1) = Res(r, j + 1) & ", " & sArr(i, 1)
              Else
                Res(r, j + 1) = sArr(i, 1)
              End If
              If sArr(r, 6) < eTime Then d = sArr(r, 6) - sArr(r, 5) Else d = eTime - sArr(r, 5)
              Res(i, j + 2) = Res(i, j + 2) + d
              Res(r, j + 2) = Res(r, j + 2) + d
              If d < 0 Then
                a = 1
              End If
            End If
          End If
        Else
          Exit For
        End If
      Next r
    End If
  Next i
  With Sheets("Check")
    .Range("G3").Resize(sRow, 12).Value = Res
    .Range("A2:R" & eRow).Sort .[A2], 1, Header:=xlYes
  End With
  Erase sArr: Erase Res
  Application.ScreenUpdating = True
End Sub
End If
Else
Exit For
End If
Next r
End If
Next i
 
HieuCD đã viết:
Code nhầm vị trí lệnh Exit for
Mã: 
Sub XetTrung()
  Dim sArr(), Res()
  Dim eRow&, sRow&, j&, i&, r&, tmp$, d As Double
  Dim stt&, kVuc$, Tram$, May$, fTime, eTime

  Application.ScreenUpdating = False
  With Sheets("Check")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow < 3 Then MsgBox ("Khong co du lieu"): Exit Sub
    .Range("A2:R" & eRow).Sort .[E2], 1, Header:=xlYes
    sArr = .Range("A3:F" & eRow).Value
  End With
  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To 12)
  For i = 1 To sRow - 1
    stt = sArr(i, 1):    kVuc = sArr(i, 2):    Tram = sArr(i, 3)
    May = sArr(i, 4):   fTime = sArr(i, 5):     eTime = sArr(i, 6)
    If fTime < eTime Then
      For r = i + 1 To sRow
        If sArr(r, 5) < eTime Then
          If sArr(r, 5) < sArr(r, 6) Then
            If sArr(r, 3) = Tram Then j = 1 Else j = 7
            If sArr(r, 4) <> May Then j = j + 3
            If sArr(r, 2) = kVuc Or j <> 10 Then
              Res(i, j) = Res(i, j) + 1
              Res(r, j) = Res(r, j) + 1
              If Len(Res(i, j + 1)) Then
                If Len(Res(i, j + 1)) < 250 Then Res(i, j + 1) = Res(i, j + 1) & ", " & sArr(r, 1) 'Gioi han so ky tu ket qua
              Else
                Res(i, j + 1) = sArr(r, 1)
              End If
              If Len(Res(r, j + 1)) Then
                If Len(Res(r, j + 1)) < 250 Then Res(r, j + 1) = Res(r, j + 1) & ", " & sArr(i, 1)
              Else
                Res(r, j + 1) = sArr(i, 1)
              End If
              If sArr(r, 6) < eTime Then d = sArr(r, 6) - sArr(r, 5) Else d = eTime - sArr(r, 5)
              Res(i, j + 2) = Res(i, j + 2) + d
              Res(r, j + 2) = Res(r, j + 2) + d
              If d < 0 Then
                a = 1
              End If
            End If
          End If
        Else
          Exit For
        End If
      Next r
    End If
  Next i
  With Sheets("Check")
    .Range("G3").Resize(sRow, 12).Value = Res
    .Range("A2:R" & eRow).Sort .[A2], 1, Header:=xlYes
  End With
  Erase sArr: Erase Res
  Application.ScreenUpdating = True
End Sub
End If
Else
Exit For
End If
Next r
End If
Next i
Nhấp chuột vào đây để mở rộng...
Bạn ơi mình chạy code cho 1 trường hợp (như file) thì thấy có 1 vấn đề như này.
Tổng số máy ở cột D chỉ là 37, nhưng kết quả trùng trạm khác máy ở J3 lại là 488. Đúng ra thì KQ luôn phải nhỏ hơn 37 (số giá trị khác nhau duy nhất ở cột D).
1.png
Mình gửi file chạy dữ liệu. Nhờ bạn xem giúp với.
 

File đính kèm

tangoctuan đã viết:
Bạn ơi mình chạy code cho 1 trường hợp (như file) thì thấy có 1 vấn đề như này.
Tổng số máy ở cột D chỉ là 37, nhưng kết quả trùng trạm khác máy ở J3 lại là 488. Đúng ra thì KQ luôn phải nhỏ hơn 37 (số giá trị khác nhau duy nhất ở cột D).
View attachment 227797
Mình gửi file chạy dữ liệu. Nhờ bạn xem giúp với.
Nhấp chuột vào đây để mở rộng...
Số 488 là số lần trùng với dòng khác không phân biệt cùng máy hay khác máy
 
HieuCD đã viết:
Số 488 là số lần trùng với dòng khác không phân biệt cùng máy hay khác máy
Nhấp chuột vào đây để mở rộng...
Vậy riêng chỗ này nhờ bạn code lại giúp để phân biệt chỉ tính khác máy thôi với. Trùng trạm và khác máy (có giao trong khoảng thời gian đó).
Tương tự như thế, cột M cũng chỉ tính khác trạm.
 
tangoctuan đã viết:
Vậy riêng chỗ này nhờ bạn code lại giúp để phân biệt chỉ tính khác máy thôi với. Trùng trạm và khác máy (có giao trong khoảng thời gian đó).
Tương tự như thế, cột M cũng chỉ tính khác trạm.
Nhấp chuột vào đây để mở rộng...
Kiểm tra lại
Mã: 
Sub XetTrung()
  Dim sArr(), Res(), Dic As Object
  Dim eRow&, sRow&, j&, i&, r&, tmp$, d As Double
  Dim stt$, stt2$, kVuc$, Tram$, May$, fTime, eTime

  Application.ScreenUpdating = False
  With Sheets("Check")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow < 3 Then MsgBox ("Khong co du lieu"): Exit Sub
    .Range("A2:R" & eRow).Sort .[E2], 1, Header:=xlYes
    sArr = .Range("A3:F" & eRow).Value
  End With
  Set Dic = CreateObject("scripting.dictionary")
  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To 12)
  For i = 1 To sRow - 1
    stt = sArr(i, 1):    kVuc = sArr(i, 2):    Tram = sArr(i, 3)
    May = sArr(i, 4):   fTime = sArr(i, 5):     eTime = sArr(i, 6)
    If fTime < eTime Then
      For r = i + 1 To sRow
        If sArr(r, 5) < eTime Then
          If sArr(r, 5) < sArr(r, 6) Then
            If sArr(r, 3) = Tram Then j = 1 Else j = 7
            If sArr(r, 4) <> May Then j = j + 3
            stt2 = sArr(r, 1)
            If sArr(r, 2) = kVuc Or j <> 10 Then
              If j = 4 Then
                tmp = Dic.Item(stt) & ","
                If InStr(1, tmp, "," & sArr(r, 4) & ",") = 0 Then
                  Res(i, j) = Res(i, j) + 1
                  Dic.Item(stt) = Dic.Item(stt) & "," & sArr(r, 4)
                End If
                tmp = Dic.Item(stt2) & ","
                If InStr(1, tmp, "," & sArr(i, 4) & ",") = 0 Then
                  Res(r, j) = Res(r, j) + 1
                  Dic.Item(stt2) = Dic.Item(stt2) & "," & sArr(i, 4)
                End If
              ElseIf j = 7 Then
                tmp = Dic.Item(stt) & ","
                If InStr(1, tmp, "," & sArr(r, 3) & ",") = 0 Then
                  Res(i, j) = Res(i, j) + 1
                  Dic.Item(stt) = Dic.Item(stt) & "," & sArr(r, 3)
                End If
                tmp = Dic.Item(stt2) & ","
                If InStr(1, tmp, "," & sArr(i, 3) & ",") = 0 Then
                  Res(r, j) = Res(r, j) + 1
                  Dic.Item(stt2) = Dic.Item(stt2) & "," & sArr(i, 3)
                End If
              Else
                Res(i, j) = Res(i, j) + 1
                Res(r, j) = Res(r, j) + 1
              End If
              If Len(Res(i, j + 1)) Then
                If Len(Res(i, j + 1)) < 250 Then Res(i, j + 1) = Res(i, j + 1) & ", " & sArr(r, 1) 'Gioi han so ky tu ket qua
              Else
                Res(i, j + 1) = sArr(r, 1)
              End If
              If Len(Res(r, j + 1)) Then
                If Len(Res(r, j + 1)) < 250 Then Res(r, j + 1) = Res(r, j + 1) & ", " & sArr(i, 1)
              Else
                Res(r, j + 1) = sArr(i, 1)
              End If
              If sArr(r, 6) < eTime Then d = sArr(r, 6) - sArr(r, 5) Else d = eTime - sArr(r, 5)
              Res(i, j + 2) = Res(i, j + 2) + d
              Res(r, j + 2) = Res(r, j + 2) + d
            End If
          End If
        Else
          Exit For
        End If
      Next r
    End If
  Next i
  With Sheets("Check")
    .Range("G3").Resize(sRow, 12).Value = Res
    .Range("A2:R" & eRow).Sort .[A2], 1, Header:=xlYes
  End With
  Erase sArr: Erase Res
  Application.ScreenUpdating = True
End Sub
 
HieuCD đã viết:
Kiểm tra lại
Mã: 
Sub XetTrung()
  Dim sArr(), Res(), Dic As Object
  Dim eRow&, sRow&, j&, i&, r&, tmp$, d As Double
  Dim stt$, stt2$, kVuc$, Tram$, May$, fTime, eTime

  Application.ScreenUpdating = False
  With Sheets("Check")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow < 3 Then MsgBox ("Khong co du lieu"): Exit Sub
    .Range("A2:R" & eRow).Sort .[E2], 1, Header:=xlYes
    sArr = .Range("A3:F" & eRow).Value
  End With
  Set Dic = CreateObject("scripting.dictionary")
  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To 12)
  For i = 1 To sRow - 1
    stt = sArr(i, 1):    kVuc = sArr(i, 2):    Tram = sArr(i, 3)
    May = sArr(i, 4):   fTime = sArr(i, 5):     eTime = sArr(i, 6)
    If fTime < eTime Then
      For r = i + 1 To sRow
        If sArr(r, 5) < eTime Then
          If sArr(r, 5) < sArr(r, 6) Then
            If sArr(r, 3) = Tram Then j = 1 Else j = 7
            If sArr(r, 4) <> May Then j = j + 3
            stt2 = sArr(r, 1)
            If sArr(r, 2) = kVuc Or j <> 10 Then
              If j = 4 Then
                tmp = Dic.Item(stt) & ","
                If InStr(1, tmp, "," & sArr(r, 4) & ",") = 0 Then
                  Res(i, j) = Res(i, j) + 1
                  Dic.Item(stt) = Dic.Item(stt) & "," & sArr(r, 4)
                End If
                tmp = Dic.Item(stt2) & ","
                If InStr(1, tmp, "," & sArr(i, 4) & ",") = 0 Then
                  Res(r, j) = Res(r, j) + 1
                  Dic.Item(stt2) = Dic.Item(stt2) & "," & sArr(i, 4)
                End If
              ElseIf j = 7 Then
                tmp = Dic.Item(stt) & ","
                If InStr(1, tmp, "," & sArr(r, 3) & ",") = 0 Then
                  Res(i, j) = Res(i, j) + 1
                  Dic.Item(stt) = Dic.Item(stt) & "," & sArr(r, 3)
                End If
                tmp = Dic.Item(stt2) & ","
                If InStr(1, tmp, "," & sArr(i, 3) & ",") = 0 Then
                  Res(r, j) = Res(r, j) + 1
                  Dic.Item(stt2) = Dic.Item(stt2) & "," & sArr(i, 3)
                End If
              Else
                Res(i, j) = Res(i, j) + 1
                Res(r, j) = Res(r, j) + 1
              End If
              If Len(Res(i, j + 1)) Then
                If Len(Res(i, j + 1)) < 250 Then Res(i, j + 1) = Res(i, j + 1) & ", " & sArr(r, 1) 'Gioi han so ky tu ket qua
              Else
                Res(i, j + 1) = sArr(r, 1)
              End If
              If Len(Res(r, j + 1)) Then
                If Len(Res(r, j + 1)) < 250 Then Res(r, j + 1) = Res(r, j + 1) & ", " & sArr(i, 1)
              Else
                Res(r, j + 1) = sArr(i, 1)
              End If
              If sArr(r, 6) < eTime Then d = sArr(r, 6) - sArr(r, 5) Else d = eTime - sArr(r, 5)
              Res(i, j + 2) = Res(i, j + 2) + d
              Res(r, j + 2) = Res(r, j + 2) + d
            End If
          End If
        Else
          Exit For
        End If
      Next r
    End If
  Next i
  With Sheets("Check")
    .Range("G3").Resize(sRow, 12).Value = Res
    .Range("A2:R" & eRow).Sort .[A2], 1, Header:=xlYes
  End With
  Erase sArr: Erase Res
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Tuyệt vời, một lần nữa cảm ơn bạn rất nhiều và chúc bạn sức khỏe!
 
HieuCD đã viết:
Chỉnh code
Mã: 
Sub ThuTu()
  Dim sArr(), Res(), Arr(), Arr2(), S, Dic As Object, iKey$
  Dim eRow&, sRow&, i&, r&, d As Double
  Dim May$, fTime, eTime, fDate&, eDate&

  With Sheets("Sheet4")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow < 3 Then MsgBox ("Khong co du lieu"): Exit Sub
    Application.ScreenUpdating = False
    .Range("A2:D" & eRow).Sort .[B2], 1, .[C2], , 1, Header:=xlYes
    sArr = .Range("B2:D" & eRow).Value
  End With
  sRow = UBound(sArr)
  Set Dic = CreateObject("scripting.dictionary")
  ReDim Res(2 To sRow, 1 To 2)

  For i = 2 To sRow
    May = sArr(i, 1)
    fDate = DateValue(sArr(i, 2)):    eDate = DateValue(sArr(i, 3))
    If eDate >= fDate Then
      ReDim Arr(fDate To eDate)
      ReDim Arr2(fDate To eDate)
      For r = fDate To eDate
        If r > fDate Then fTime = r Else fTime = sArr(i, 2)
        If r < eDate Then eTime = r + 1 Else eTime = sArr(i, 3)
        d = Round((eTime - fTime) * 1440, 2)
        iKey = sArr(i, 1) & "#" & r
        If Dic.exists(iKey) = False Then
          Dic.Add iKey, Array(1, d)
        Else
          S = Dic.Item(iKey)
          S(0) = S(0) + 1
          S(1) = S(1) + d
          Dic.Item(iKey) = S
        End If
        If fDate = eDate Then
          Arr(r) = Dic.Item(iKey)(0)
          Arr2(r) = iKey
        Else
          Arr(r) = Dic.Item(iKey)(0) & " (" & Format(r, "dd/mm") & ")"
          Arr2(r) = iKey & " (" & Format(r, "dd/mm") & ")"
        End If
      Next r
      Res(i, 1) = Join(Arr, "; ")
      Res(i, 2) = Join(Arr2, "; ")
    End If
  Next i

  For i = 2 To sRow
    fDate = DateValue(sArr(i, 2)):    eDate = DateValue(sArr(i, 3))
    If eDate >= fDate Then
      For r = fDate To eDate
        iKey = sArr(i, 1) & "#" & r
        Res(i, 2) = Replace(Res(i, 2), iKey, Dic.Item(iKey)(1))
      Next r
    End If
  Next i

  With Sheets("Sheet4")
    .Range("E3").Resize(sRow - 1, 2) = Res
    .Range("A2:F" & eRow).Sort .[A2], 1, Header:=xlYes
  End With
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn ơi xem giúp hộ mình file dữ liệu này chạy với code này thì báo lỗi không biết là lỗi gì nhỉ?
 

File đính kèm

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

Q
Hỏi về công thức dò giá
Trả lời
6
Đọc
146
thanthanhan0801
T
H
Tìm kết quả trả về theo loại
Trả lời
7
Đọc
39
hienxh_1979
H
V
  • Question Question
Tách số liệu từ bảng tính ngang theo điều kiện
Trả lời
6
Đọc
151
vanlinh_2904
V
N
  • Question Question
VBA - copy các sheets unhide và dạng giá trị theo vùng xác định
Trả lời
6
Đọc
317
nguyenhuong34
nguyenhuong34
ThanhPhongDN
hỏi về cách thay đổi giá trị một ô sau khi nhập một giá trị vào đó
Trả lời
7
Đọc
121
vietduc147258
V
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Chấp nhận
2
Trả lời
34
Đọc
13K
hungbon7890
hungbon7890
LongHoang123
  • Question Question
Xin hướng dẫn: Cách tạo vùng in dựa trên dữ liệu của listbox bằng VBA!!!
Trả lời
0
Đọc
22
LongHoang123
LongHoang123
P
Xin trợ giúp cách lập lịch trực tịnh tiến dần cho 1 nhóm người.
Trả lời
0
Đọc
20
phambahoang
P
HeSanbi
  • Đã giải quyết
LocalizeXL v1.72 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3
Trả lời
59
Đọc
9K
125479980
125479980
A
  • Question Question
code vba chuyển chuỗi thành text
Trả lời
11
Đọc
2K
SonBDND
S
V
Xin giúp em file theo dõi thanh toán có bị quá hạn không, quá bao nhiêu ngày và bao nhiêu tiền ạ
Trả lời
11
Đọc
292
HUONGHCKT
H
Tandattb
Xin cách Khắc phục lỗi "Path/File access error"
Trả lời
8
Đọc
275
Tandattb
Tandattb
ThanhPhongDN
Nhờ giúp đỡ về công thức trong google sheet
    • Cười
Trả lời
4
Đọc
80
thuytrangbp28
T
saobekhonglac
Tạo form vòng quay may mắn
    • Thích
2
Trả lời
35
Đọc
15K
VetMini
V
D
Thống kê dữ liệu theo điều kiện
Trả lời
5
Đọc
129
VetMini
V
noisy
Xin file tính chế độ chuyên cần
    • Cười
Trả lời
0
Đọc
35
noisy
noisy
PhanTuHuong
CHỌN VÀ SỬ DỤNG MÁY LỌC KHÔNG KHÍ
    • Cảm ơn
Trả lời
3
Đọc
709
hvnhpro
H
hanhlx88
Nhờ giúp file Excel báo lỗi: Excel cannot complete this task with available resources
Trả lời
2
Đọc
116
leonguyenz
leonguyenz
K
Em nhờ anh chị làm giúp file vòng quay may mắn
Trả lời
1
Đọc
80
Nhattanktnn
Nhattanktnn
GPE-Trợ Lý
[GPE] TALK SHOW HÀM QUERY - BÍ KÍP BIẾN DỮ LIỆU KHỔNG LỒ THÀNH THÔNG TIN HỮU ÍCH TRONG TÍCH TẮC
    • Thích
    • Yêu thích
Trả lời
4
Đọc
2K
PhanTuHuong
PhanTuHuong
Xem thêm…

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

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới.
Back
Top Bottom