Sao không ai đọc rồi trả lời vậy ạ
(
Em có tìm được đoạn code của anh HoangDanh từ mấy năm trước nhưng dùng vào Nhật ký chung của công ty em thì kết quả vẫn bị lệch. Ai cho em xin ý kiến vớiiiiiiiii!
CODE:
Sub Taoso()
Dim i As Long, Rw As Long, t As Double
Dim Chungtu As Range, Ci8 As Range, Ci9 As Range
Dim DK1 As Boolean, Dk2 As Boolean, Dk3 As Boolean, Dk4 As Boolean
Application.ScreenUpdating = False
t = Timer
Range("A7:I65536").ClearContents
With Sheets("DATA")
Rw = .[D65536].End(xlUp).Row
Set Chungtu = .Range("A7:A" & Rw)
End With
With Chungtu
.Resize(, 4).Copy Destination:=[A7]
.Offset(, 6).Copy Destination:=[G7]
.Offset(, 4).Resize(, 2).Copy Destination:=[H7]
End With
Set Chungtu = Nothing
For i = 7 To [D65536].End(xlUp).Row
With Cells(i, 5)
Set Ci8 = .Offset(, 3): Set Ci9 = .Offset(, 4)
DK1 = ((Cells(i, 1) = Cells(i + 1, 1)) * (.Offset(, 3) > 0)) = 1
Dk2 = ((Cells(i, 1) = Cells(i - 1, 1)) * (.Offset(, 3) > 0)) = 1
Dk3 = ((Cells(i, 1) = Cells(i + 1, 1)) * (.Offset(, 4) > 0)) = 1
Dk4 = ((Cells(i, 1) = Cells(i - 1, 1)) * (.Offset(, 4) > 0)) = 1
'-------------------------------------------------------------------------------------
'1a.> 1 No 1 Co voi No truoc
If DK1 And Ci8 = Cells(i + 1, 9) Then
.Value = Cells(i + 1, 4)
'1b.> 1 No 1 Co voi Co truoc
ElseIf Dk2 And Ci8 = Cells(i - 1, 9) Then
.Value = Cells(i - 1, 4)
'2a.> 2 No 1 Co voi No truoc
ElseIf DK1 And Ci8 + Cells(i + 1, 8-) = Cells(i + 2, 9) Then
.Value = Cells(i + 2, 4)
ElseIf DK1 And Ci8 + Cells(i - 1, 8-) = Cells(i + 1, 9) Then
.Value = Cells(i + 1, 4)
'2b.> 2 No 1 Co voi Co truoc
ElseIf Dk2 And Ci8 + Cells(i + 1, 8-) = Cells(i - 1, 9) Then
.Value = Cells(i - 1, 4)
ElseIf Dk2 And Ci8 + Cells(i - 1, 8-) = Cells(i - 2, 9) Then
.Value = Cells(i - 2, 4)
'3a.> 3 No 1 Co voi No truoc
ElseIf DK1 And Ci8 + Cells(i + 1, 8-) + Cells(i + 2, 8-) = Cells(i + 3, 9) Then
.Value = Cells(i + 3, 4)
ElseIf DK1 And Ci8 + Cells(i - 1, 8-) + Cells(i + 1, 8-) = Cells(i + 2, 9) Then
.Value = Cells(i + 2, 4)
ElseIf DK1 And Ci8 + Cells(i - 1, 8-) + Cells(i - 2, 8-) = Cells(i + 1, 9) Then
.Value = Cells(i + 1, 4)
'3b.> 3 No 1 Co voi Co truoc
ElseIf DK1 And Ci8 + Cells(i + 1, 8-) + Cells(i + 2, 8-) = Cells(i - 1, 9) Then
.Value = Cells(i - 1, 4)
ElseIf DK1 And Ci8 + Cells(i + 1, 8-) + Cells(i - 1, 8-) = Cells(i - 2, 9) Then
.Value = Cells(i - 2, 4)
ElseIf Dk2 And Ci8 + Cells(i - 1, 8-) + Cells(i - 2, 8-) = Cells(i - 3, 9) Then
.Value = Cells(i - 3, 4)
'Tu truong hop 4a tro ve sau thuat toan se khac, do la dao chieu giua No va Co
'4a.> 1 No 2 Co voi No truoc
ElseIf Dk3 And Cells(i + 1, 9) <> 0 And Ci9 + Cells(i + 1, 9) = Cells(i - 1, 8-) Then
.Value = .Offset(, -1)
.Offset(, -1) = .Offset(-1, -1)
ElseIf Dk4 And Ci9 + Cells(i - 1, 9) = Cells(i - 2, 8-) Then
.Value = .Offset(, -1)
.Offset(, -1) = .Offset(-2, -1)
'4b.> 1 No 2 Co voi Co truoc
ElseIf Dk3 And Cells(i + 1, 9) <> 0 And Ci9 + Cells(i + 1, 9) = Cells(i + 2, 8-) Then
.Value = .Offset(, -1)
.Offset(, -1) = .Offset(2, -1)
ElseIf Dk3 And Cells(i - 1, 9) <> 0 And Ci9 + Cells(i - 1, 9) = Cells(i + 1, 8-) Then
.Value = .Offset(, -1)
.Offset(, -1) = .Offset(1, -1)
'5a.> 1 No 3 Co voi No truoc
ElseIf Dk3 And Cells(i + 1, 9) <> 0 And Ci9 + Cells(i + 1, 9) + Cells(i + 2, 9) = Cells(i - 1, 8-) Then
.Value = .Offset(, -1)
.Offset(, -1) = .Offset(-1, -1)
ElseIf Dk3 And Cells(i + 1, 9) <> 0 And Ci9 + Cells(i + 1, 9) + Cells(i - 1, 9) = Cells(i - 2, 8-) Then
.Value = .Offset(, -1)
.Offset(, -1) = .Offset(-2, -1)
ElseIf Dk4 And Cells(i - 1, 9) <> 0 And Ci9 + Cells(i - 1, 9) + Cells(i - 2, 9) = Cells(i - 3, 8-) Then
.Value = .Offset(, -1)
.Offset(, -1) = .Offset(-3, -1)
'5b.> 1 No 3 Co voi Co truoc
ElseIf Dk3 And Cells(i + 1, 9) <> 0 And Ci9 + Cells(i + 1, 9) + Cells(i + 2, 9) = Cells(i + 3, 8-) Then
.Value = .Offset(, -1)
.Offset(, -1) = .Offset(3, -1)
ElseIf Dk3 And Cells(i + 1, 9) <> 0 And Ci9 + Cells(i + 1, 9) + Cells(i - 1, 9) = Cells(i + 2, 8-) Then
.Value = .Offset(, -1)
.Offset(, -1) = .Offset(2, -1)
ElseIf Dk3 And Cells(i - 1, 9) <> 0 And Ci9 + Cells(i - 1, 9) + Cells(i - 2, 9) = Cells(i + 1, 8-) Then
.Value = .Offset(, -1)
.Offset(, -1) = .Offset(1, -1)
End If
'-------------------------------------------------------------------------------------
If .Value <> "" And .Offset(, -1) <> "" Then .Offset(, 1).Value = Ci8 + Ci9
End With
Next i
Set Ci8 = Nothing: Set Ci9 = Nothing
DelRow ' Huy dong lenh nay de xem va sua chua cac thuat toan o tren
[A2] = Timer - t
[A6:G6].AutoFilter
Application.ScreenUpdating = True
End Sub
'=============================================================================================
Sub DelRow()
Dim Cell As Range, Rng As Range, r As Long
Set Rng = Range("F7:F" & [D65536].End(xlUp).Row)
For Each Cell In Rng
Cell.Offset(, 2).Value = Cell.Row
If Cell.Value = 0 Then Cell.EntireRow.Clear
Next
Range("A7:H65536").Sort key1:=[H7], order1:=xlAscending
[D7
65536].HorizontalAlignment = xlCenter
[E7:E65536].HorizontalAlignment = xlCenter
[G7:G65536].HorizontalAlignment = xlCenter
[F7:F65536].NumberFormat = "#,##0"
Columns("H:I").Clear
Set Rng = Nothing: Set Cell = Nothing
End Sub
'=============================================================================================
Sub test()
Dim ChungtuData As Range, SotienData As Range, ChungtuConvert As Range, SotienConvert As Range
Dim Cell As Range, t As Double
Application.ScreenUpdating = False
t = Timer
[A2
65536].Clear
[B1] = "Chung tu"
With Sheets("DATA")
Set ChungtuData = .Range("A7:A" & .[A65536].End(xlUp).Row)
Set SotienData = ChungtuData.Offset(, 4)
End With
ChungtuData.Copy Destination:=[B2]
[B1:B65536].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[A1], Unique:=True
[B2:B65536].Clear
[B1] = "DATA"
With Sheets("Convert")
Set ChungtuConvert = .Range("A7:A" & .[A65536].End(xlUp).Row)
Set SotienConvert = ChungtuConvert.Offset(, 5)
End With
For Each Cell In Range("A2:A" & [A65536].End(xlUp).Row)
If Cell <> "" Then
Cell.Offset(, 1) = WorksheetFunction.SumIf(ChungtuData, Cell, SotienData)
Cell.Offset(, 2) = WorksheetFunction.SumIf(ChungtuConvert, Cell, SotienConvert)
Cell.Offset(, 3) = Cell.Offset(, 1) - Cell.Offset(, 2)
End If
Next
[E1] = Timer - t
[A1
1].AutoFilter
Set ChungtuData = Nothing: Set SotienData = Nothing
Set ChungtuConvert = Nothing: Set SotienConvert = Nothing
Application.ScreenUpdating = True
End Sub
'==============================================================================================
Sub Taosocai()
Dim Cell As Range, r As Long, t As Double, DK1 As Boolean, Ngay1 As Boolean, Ngay2 As Boolean
Application.ScreenUpdating = False
t = Timer: [A7:G65536].ClearContents: r = 7
If Not IsDate([B2]) Or Not IsDate([B3]) Then Exit Sub
With Sheets("Convert")
For Each Cell In .Range("A7:A" & .[A65536].End(xlUp).Row)
If Cell.Offset(, 1).Row = 5 Then MsgBox "Sheet Convert chua co du lieu!": Exit Sub
If Not IsDate(Cell.Offset(, 1)) Then MsgBox "Gia tri ngay trong Cell : Convert!" & Cell.Offset(, 1).Address & " Khong dung": Exit Sub
Ngay1 = DateValue(Cell.Offset(, 1)) >= DateValue([B2])
Ngay2 = DateValue(Cell.Offset(, 1)) <= DateValue([B3])
DK1 = InStr(1, Cell.Offset(, 3), [F3], 1) = 1
If DK1 Or InStr(1, Cell.Offset(, 4), [F3], 1) = 1 Then
Select Case [C3]
Case 0
Cells(r, 1) = Cell
Cells(r, 2) = Cell.Offset(, 1)
Cells(r, 3) = Cell.Offset(, 2)
If DK1 Then
Cells(r, 4) = Cell.Offset(, 4)
Cells(r, 5) = Cell.Offset(, 5)
Else
Cells(r, 4) = Cell.Offset(, 3)
Cells(r, 6) = Cell.Offset(, 5)
End If
Cells(r, 7) = Cell.Offset(, 6)
r = r + 1
Case 1
If Ngay1 * Ngay2 = 1 Then
Cells(r, 1) = Cell
Cells(r, 2) = Cell.Offset(, 1)
Cells(r, 3) = Cell.Offset(, 2)
If DK1 Then
Cells(r, 4) = Cell.Offset(, 4)
Cells(r, 5) = Cell.Offset(, 5)
Else
Cells(r, 4) = Cell.Offset(, 3)
Cells(r, 6) = Cell.Offset(, 5)
End If
Cells(r, 7) = Cell.Offset(, 6)
r = r + 1
End If
End Select
Cells(r, 4).HorizontalAlignment = xlCenter
Cells(r, 5).NumberFormat = "#,##0"
Cells(r, 6).NumberFormat = "#,##0"
Cells(r, 7).HorizontalAlignment = xlCenter
End If
Next
End With
[C3] = 0
[G3] = Timer - t
[A6:G6].AutoFilter
Application.ScreenUpdating = True
End Sub
