Public Sub Laydulieu()
Dim sArr(), dArr(), arr(), sarr1(), darr1(), dArr2(), arr4(), dArr4(), sArr4()
Dim Dic As Object, i As Long, J As Long, K As Long, R As Long, KT As String
Dim Rng As Range, v As Variant, Stt As Long, Sodem As Long, Tam As String
Set Dic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
KT = ", K" & ChrW$(237) & "ch th" & ChrW$(432) & ChrW$(7899) & "c: "
With Sheets("Dulieu")
Set Rng = .Range("B4", .Range("B65535").End(3)).Resize(, 6)
arr = .Range("B3:G3").Value
sArr = .Range("L4", .Range("L65535").End(3)).Resize(, 12).Value
End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'code bo sung
If Sheet1.Range("w2").Value = "" Then
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Sheet1.[b4] = "" Then Exit Sub
For i = 1 To UBound(sArr)
Dic(sArr(i, 1)) = 1
Next i
ReDim dArr(1 To UBound(sArr) * 2, 1 To 9)
For Each v In Dic.keys()
For i = 1 To UBound(sArr)
If sArr(i, 1) = v Then
Sodem = Sodem + 1
If Sodem = 1 Then
K = K + 1: Stt = Stt + 1
dArr(K, 1) = Stt
dArr(K, 2) = Application.VLookup(v, Rng, 2, False)
For J = 3 To 4
Tam = Application.VLookup(v, Rng, J, False)
If Tam <> Empty Then dArr(K, 2) = dArr(K, 2) & "; " & arr(1, J) & ": " & Tam
Next J
End If
K = K + 1
If sArr(i, 4) <> Empty Then
dArr(K, 2) = sArr(i, 3) & KT & sArr(i, 4) & " m"
Else
dArr(K, 2) = sArr(i, 3)
End If
dArr(K, 3) = sArr(i, 5): dArr(K, 4) = sArr(i, 6): dArr(K, 5) = sArr(i, 7)
dArr(K, 6) = sArr(i, 8): dArr(K, 7) = sArr(i, 9): dArr(K, 8) = sArr(i, 10)
dArr(K, 9) = sArr(i, 11)
End If
Next i
Sodem = 0
Next
With Sheets("ThamDinh")
.Range("A6:N10000").ClearContents
.Range("A6:N10000").ClearFormats
.Range("A6").Resize(K, 9) = dArr
End With
Set Dic = Nothing
Application.ScreenUpdating = True
Sheet3.Activate
Call tinhtien2
Call dinhdang2
''''''''''''''''''''''''''''''''''''''''''''''''
Else
ReDim darr1(1 To UBound(sArr), 1 To 11)
For n = 1 To UBound(sArr)
If sArr(n, 12) = Sheet1.[w2] Then
K = K + 1
darr1(K, 1) = sArr(n, 1)
For l = 2 To 11
darr1(K, l) = sArr(n, l)
Next l
End If
Next n
'(đoạn này mình tạo mãng lấy dữ liệu theo đợt ở cột W (dữ liệu cột W minht ạo thêm so với file gốc)
''''''''''''''''''''''''''''''
If Sheet1.[b4] = "" Then Exit Sub
For i = 1 To UBound(darr1)
Dic(darr1(i, 1)) = 1
Next i
ReDim dArr2(1 To UBound(darr1) * 2, 1 To 9)
For Each v In Dic.keys()
For i = 1 To UBound(darr1)
If darr1(i, 1) = v Then
Sodem = Sodem + 1
If Sodem = 1 Then
K = K + 1: Stt = Stt + 1
dArr2(K, 1) = Stt
dArr2(K, 2) = Application.VLookup(v, Rng, 2, False)
For J = 3 To 4
Tam = Application.VLookup(v, Rng, J, False)
If Tam <> Empty Then dArr2(K, 2) = darr1(K, 2) & "; " & arr(1, J) & ": " & Tam
Next J
End If
K = K + 1
If darr1(i, 4) <> Empty Then
dArr2(K, 2) = darr1(i, 3) & KT & darr1(i, 4) & " m"
Else
dArr2(K, 2) = darr1(i, 3)
End If
dArr2(K, 3) = darr1(i, 5): dArr2(K, 4) = darr1(i, 6): dArr2(K, 5) = darr1(i, 7)
dArr2(K, 6) = darr1(i, 8): dArr2(K, 7) = darr1(i, 9): dArr2(K, 8) = darr1(i, 10)
dArr2(K, 9) = darr1(i, 11)
End If
Next i
Sodem = 0
Next
With Sheets("ThamDinh")
.Range("A6:N10000").ClearContents
.Range("A6:N10000").ClearFormats
.Range("A6").Resize(K, 9) = dArr2
End With
Set Dic = Nothing
Application.ScreenUpdating = True
Sheet3.Activate
Call tinhtien2
Call dinhdang2
End If
End Sub[code]
Nó báo lỗi ở dòng [code]Tam = Application.VLookup(v, Rng, J, False)
