Nhờ anh chị chỉnh sửa giúp code cho file chạy nhanh hơn

[nguyentheviet86]

Thân gửi anh chị !
Nhờ anh chị xem giúp em phần code, hiện tại em đã viết code nhưng nó chỉ chạy nhanh khi có dữ liệu ít, còn dữ liệu hơn 1500 mã id nó chạy hơi lâu
Bên Sheet công là dữ liệu của em, muốn chạy sang phần sheet y tế
Em cảm ơn anh chị ạ

 

[VuVanHao]

2 mã id bạn làm mẫu bên sheet y tế không tìm thấy bên sheet Công. Bạn lấy ví dụ cũng thật lạ

 

[nguyentheviet86]

2 mã id bạn làm mẫu bên sheet y tế không tìm thấy bên sheet Công. Bạn lấy ví dụ cũng thật lạ

Em quên mất chưa update lại dữ liệu ạ

2 mã id bạn làm mẫu bên sheet y tế không tìm thấy bên sheet Công. Bạn lấy ví dụ cũng thật lạ

Em quên mất chưa update lại dữ liệu ạ, em gửi lại anh chị ạ

 

[VuVanHao]

Không hiểu cái số trước dấu ~ nghĩa là gì. Mình tạm thời bỏ qua. Bạn xem code rồi chỉnh nhé

Sub ChamCong()
Dim Dic1 As Object, iRow As Long, i As Long
Dim Arr() As Variant, TmpArr As Variant
With Sheet1
.Range("A2:D2000").ClearContents
  Set Dic1 = CreateObject("Scripting.Dictionary")
    TmpArr = Sheet2.Range("A2:D4592").Value
    ReDim Arr(1 To UBound(TmpArr, 1), 1 To 4)
    For iRow = 1 To UBound(TmpArr, 1)
        If Not IsEmpty(TmpArr(iRow, 1)) And Not Dic1.exists(TmpArr(iRow, 1)) Then
            i = i + 1
             Dic1.Add TmpArr(iRow, 1), i
             Arr(i, 1) = i
             Arr(i, 2) = TmpArr(iRow, 1)
             Arr(i, 3) = TmpArr(iRow, 2)
             Arr(i, 4) = Format(TmpArr(iRow, 3), "dd/mm") & ":" & TmpArr(iRow, 4)
        Else
            Arr(Dic1.Item(TmpArr(iRow, 1)), 4) = Arr(Dic1.Item(TmpArr(iRow, 1)), 4) & ",     " & Format(TmpArr(iRow, 3), "dd/mm") & ":" & TmpArr(iRow, 4)
        End If
    Next iRow
.Range("A2").Resize(i, 4).Value = Arr
End With
End Sub

 

[nguyentheviet86]

Không hiểu cái số trước dấu ~ nghĩa là gì. Mình tạm thời bỏ qua. Bạn xem code rồi chỉnh nhé

Sub ChamCong()
Dim Dic1 As Object, iRow As Long, i As Long
Dim Arr() As Variant, TmpArr As Variant
With Sheet1
.Range("A2:D2000").ClearContents
  Set Dic1 = CreateObject("Scripting.Dictionary")
    TmpArr = Sheet2.Range("A2:D4592").Value
    ReDim Arr(1 To UBound(TmpArr, 1), 1 To 4)
    For iRow = 1 To UBound(TmpArr, 1)
        If Not IsEmpty(TmpArr(iRow, 1)) And Not Dic1.exists(TmpArr(iRow, 1)) Then
            i = i + 1
             Dic1.Add TmpArr(iRow, 1), i
             Arr(i, 1) = i
             Arr(i, 2) = TmpArr(iRow, 1)
             Arr(i, 3) = TmpArr(iRow, 2)
             Arr(i, 4) = Format(TmpArr(iRow, 3), "dd/mm") & ":" & TmpArr(iRow, 4)
        Else
            Arr(Dic1.Item(TmpArr(iRow, 1)), 4) = Arr(Dic1.Item(TmpArr(iRow, 1)), 4) & ",     " & Format(TmpArr(iRow, 3), "dd/mm") & ":" & TmpArr(iRow, 4)
        End If
    Next iRow
.Range("A2").Resize(i, 4).Value = Arr
End With
End Sub

Em cảm ơn anh chị đã giúp đỡ , file chạy nhanh hơn và dễ nhìn hơn ạ

 

[nguyentheviet86]

Không hiểu cái số trước dấu ~ nghĩa là gì. Mình tạm thời bỏ qua. Bạn xem code rồi chỉnh nhé

Sub ChamCong()
Dim Dic1 As Object, iRow As Long, i As Long
Dim Arr() As Variant, TmpArr As Variant
With Sheet1
.Range("A2:D2000").ClearContents
  Set Dic1 = CreateObject("Scripting.Dictionary")
    TmpArr = Sheet2.Range("A2:D4592").Value
    ReDim Arr(1 To UBound(TmpArr, 1), 1 To 4)
    For iRow = 1 To UBound(TmpArr, 1)
        If Not IsEmpty(TmpArr(iRow, 1)) And Not Dic1.exists(TmpArr(iRow, 1)) Then
            i = i + 1
             Dic1.Add TmpArr(iRow, 1), i
             Arr(i, 1) = i
             Arr(i, 2) = TmpArr(iRow, 1)
             Arr(i, 3) = TmpArr(iRow, 2)
             Arr(i, 4) = Format(TmpArr(iRow, 3), "dd/mm") & ":" & TmpArr(iRow, 4)
        Else
            Arr(Dic1.Item(TmpArr(iRow, 1)), 4) = Arr(Dic1.Item(TmpArr(iRow, 1)), 4) & ",     " & Format(TmpArr(iRow, 3), "dd/mm") & ":" & TmpArr(iRow, 4)
        End If
    Next iRow
.Range("A2").Resize(i, 4).Value = Arr
End With
End Sub

Anh chij cho em hỏi với ạ,bây h số dữ liệu của em lên gần đến 9000 dòng , khi em điều chỉnh lại số dòng thì nó báo lỗi ạ
Mong anh chị giúp đỡ ạ, em cảm ơn

 

[Hoàng Tuấn 868]

Anh chij cho em hỏi với ạ,bây h số dữ liệu của em lên gần đến 9000 dòng , khi em điều chỉnh lại số dòng thì nó báo lỗi ạ
Mong anh chị giúp đỡ ạ, em cảm ơn
View attachment 272819

Mình chưa xem file nhưng thử thay chỗ đỏ đỏ thành khoảng 20000 xem sao
.Range("A22000").ClearContents
TmpArr = Sheet2.Range("A2:D4592").Value

 

[nguyentheviet86]

Mình chưa xem file nhưng thử thay chỗ đỏ đỏ thành khoảng 20000 xem sao
.Range("A22000").ClearContents
TmpArr = Sheet2.Range("A2:D4592").Value

dạ không được anh ạ, mong anh xem file giúp em ạ

 

[Hoàng Tuấn 868]

dạ không được anh ạ, mong anh xem file giúp em ạ

Bạn kiểm tra lại nhé.

 

[nguyentheviet86]

Bạn kiểm tra lại nhé.

Em cảm ơn anh nhé, anh cho em hỏi chút có thể làm các ngày nó thẳng với nhau cho dễ nhìn không ạ

 

[Hoàng Tuấn 868]

làm các ngày nó thẳng với nhau cho dễ nhìn

Không biết đúng ý chưa.

 

[nguyentheviet86]

Không biết đúng ý chưa.
View attachment 272845

Không biết đúng ý chưa.
View attachment 272845

Dạ được rồi ạ, em cảm ơn anh chị đã giúp đỡ file ạ