sArr lấy từ dòng 6, dArr lấy từ dòng 7,nên số dòng của dArr ít hơn sArr 1 dòng, nên khai báo dArr:
With Sheets("Tong hop cong")
If CStr(.Range("C7")) <> "" Then
.Range("C8:BP7000").ClearContents
End If
sArr = .Range("B6").Resize(, 34).Value 'lay cot ngay
For J = 4 To 34
If sArr(1, J) <> Empty Then
If IsDate(sArr(1, J)) Then Col.Item(Day(sArr(1, J))) = J
End If
Next J
sArr = .Range("B7", .Range("B65000").End(xlUp)).Value 'lay dong
ReDim dArr(1 To UBound(sArr, 1), 1 To 34)
For I = 1 To UBound(sArr, 1)
If Len(sArr(I, 1)) > 0 Then
Dic.Item(CStr(sArr(I, 1))) = I
End If
Next I
End With
Bạn chạy Sub này thử
Sub Tonghopvattu()
Application.ScreenUpdating = False
Dim Dic As Object, Tem As String
Dim sArr(), dArr(), tArr(), Er As Long
Dim I As Long, J As Long, N As Long, K As Long, LaMa As Long, Stt As Long, Rws As Long
Set Dic = CreateObject("scripting.Dictionary")
With Sheets("xuatDL")
sArr = .Range("C7", .Range("C65536").End(3)).Resize(, 5).Value
tArr = .Range("L1:N1").Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 5)
With Sheets("THVT")
With .Range("A6:I1000")
.ClearContents: .Interior.ColorIndex = 0: .Borders.LineStyle = 0: .Font.Bold = False
End With
For N = 1 To 3
Stt = 0: LaMa = LaMa + 1: K = K + 1
dArr(K, 1) = ChrW(LaMa + 64): dArr(K, 2) = tArr(1, N)
.Range("A" & K + 5).Resize(, 9).Interior.ColorIndex = 20
.Range("A" & K + 5).Resize(, 9).Font.Bold = True
For I = 1 To UBound(sArr, 1)
If sArr(I, 1) <> Empty Then
If Left(sArr(I, 1), 1) = Left(tArr(1, N), 1) Then
Tem = sArr(I, 1)
If Not Dic.Exists(Tem) Then
K = K + 1: Stt = Stt + 1
Dic.Add Tem, K
dArr(K, 1) = Stt: dArr(K, 2) = sArr(I, 1)
dArr(K, 3) = sArr(I, 2): dArr(K, 4) = sArr(I, 3)
dArr(K, 5) = sArr(I, 5)
Else
Rws = Dic.Item(Tem): dArr(Rws, 5) = dArr(Rws, 5) + sArr(I, 5)
End If
End If
End If
Next I
Next N
.Range("A6").Resize(K, 5) = dArr:
.Range("A6").Resize(K, 9).Borders.LineStyle = 1
If Not IsNumeric(.Range("A65536").End(3)) Then .Range("A65536").End(3).EntireRow.Delete
Er = .Range("A65536").End(3).Row
For I = Er To 6 Step -1
If Not IsNumeric(.Range("A" & I)) Then
.Range("B" & I + 1 & ":I" & Er).Sort Key1:=.Range("C" & I + 1)
Er = I - 1
End If
Next I
End With
Set Dic = Nothing
End SubCám ơn chị rất nhiều. chị có thể chỉnh sửa bài #1245 giúp e được không?
Các bạn và bạn PacificPR giúp mình thêm code này nữa nhé!
có ai không, giúp mình với đi
mình tìm được trên diễn đàn này, và có chỉnh sữa cho phù hợp hơn tí thôi. có mấy code khóa quá nên nhờ diễn đàn giúpHình như cái File này em đã gặp ở đâu trên diễn đàn mình roài thì phải. (Hình như bài của anh "Sơn thủ bạc")
Bạn qua đây có bài giống của bạn nè
Mình có qua đó xem rồi và cũng timif được 1 1file gần tương tự nhưng mình chỉnh lại cứ báo lỗi.
Private Sub cmdThem_Click()
Dim Lr As Long, stt As Long
Lr = Sheet7.Cells(Rows.Count, "B").End(3).Row
If Me.cmbMaTS = "" Then
MsgBox ("Ban chua chon kieu ma tai san")
Me.cmbMaTS.SetFocus
Exit Sub
End If
If Me.txtMaTS = "" Then
MsgBox ("Ban chua nhap ma tai san")
Me.txtMaTS.SetFocus
Exit Sub
End If
With Sheet7
stt = Application.WorksheetFunction.CountIf(.Range("$B$2:B" & Lr), Me.cmbMaTS.Value & " * ")
Select Case stt
Case Is < 10
.Range("B" & Lr + 1) = StrConv(cmbMaTS.Value & Me.txtMaTS.Value & "00" & stt + 1, vbUpperCase)
Case Is < 100
.Range("B" & Lr + 1) = StrConv(cmbMaTS.Value & Me.txtMaTS.Value & "0" & stt + 1, vbUpperCase)
Case Else
.Range("B" & Lr + 1) = StrConv(cmbMaTS.Value & Me.txtMaTS.Value & stt + 1, vbUpperCase)
End Select
End With
End Substt = Application.WorksheetFunction.CountIf(.Range("$B$2:B" & Lr), Me.cmbMaTS.Value & " * ")
Bạn thêm vào 2 dòng lệnh sau, nếu đặt biến ngay từ đầu thì tốt hơn (t = Ubound(...))
For i = 1 To UBound(arr1, 1)
If i < UBound(arr, 1) + 1 Then '<=== Them vao
If DateAdd("m", 13, arr1(i, 1)) >= Date Then
k1 = k1 + 1
res1(k1, 1) = arr1(i, 1)
res1(k1, 2) = arr1(i, 2)
End If
End If '<=== Them vao
Next iBác ơi, vậy trong trường hợp i>ubound(arr,1) thì làm thế nào?
