Viết Code update tự động dữ liệu (1 người xem)

[lehongthanh]

Chào anh em trên diễn đàn
Xin phép bác Tuấn Anh
Mình có file excel của bác Tuấn Anh gửi, nhưng đọc code mù tịt quá.
Mình có 1 vài thắc mắc mong anh em chỉ giáo
- Trong code không thấy chỗ nào nói kết quả hàng ngày được cập nhật ở đâu? Như thế nào?
- Có thề update tự động hoặc update thủ công (bằng tay), cái này mình chưa làm được. Mong nhận được sự giúp đỡ của anh em. Đọc code mà chẳng hiểu lấy dữ liệu từ đâu

Option Explicit
Sub TruotPT()
On Error Resume Next
Range("BE2:BI3600").ClearContents
If Sheets("TH").Chk1 Then
TruotPTCap
Exit Sub
End If
Dim Duoi, Sh, Lh, i, j, k, Cau, VT1, VT2, Mang(), A, B, BB, LS
Duoi = Range("A" & Rows.Count).End(xlUp).Row - Sheets("TH").SpB1.Value
Set Lh = Range(Cells(Duoi - 1, 2), Cells(Duoi - 1, 28))
For Each VT1 In Lh
For A = 1 To Len(VT1)
For Each VT2 In Lh
For B = 1 To Len(VT2)
j = 0
tiep:
Cau = CStr(Mid(VT1(1 - j, 1), A, 1) & Mid(VT2(1 - j, 1), B, 1))
Set Sh = Range(Cells(Duoi - j, 29), Cells(Duoi - j, 55))
If WorksheetFunction.CountIf(Sh, CStr(Cau)) = False Then
j = j + 1
GoTo tiep
End If
If j > Sheets("TH").SpB2.Value Then
k = k + 1
Cau = CStr(Mid(VT1(2, 1), A, 1) & Mid(VT2(2, 1), B, 1))
Cells(1, 57) = "C" & ChrW(7847) & "u tr" & ChrW(432) & ChrW(7907) & "t Ph" & ChrW(7893) & " thông b" & ChrW(7841) & "ch th" & ChrW(7911)
Cells(2, 57) = "Lô"
Cells(2, 58) = "Tr" & ChrW(432) & ChrW(7907) & "t dài"
Cells(2, 59) = "L" & ChrW(7883) & "ch s" & ChrW(7917)
Cells(2, 60) = "Average"
Cells(2, 61) = "Gi" & ChrW(7843) & "i"
Cells(2 + k, 57) = Cau
Cells(2 + k, 61) = Cells(1, VT1.Column) & "." & A & " - " & Cells(1, VT2.Column) & "." & B
Cells(2 + k, 58) = j & " Ngày"
For i = 2 To Duoi - j
Cau = CStr(Mid(Cells(i, VT1.Column), A, 1) & Mid(Cells(i, VT2.Column), B, 1))
Set Sh = Range(Cells(i + 1, 29), Cells(i + 1, 55))
If WorksheetFunction.CountIf(Sh, CStr(Cau)) = False Then
LS = LS + 1
Else
If LS >= j Then
BB = BB + 1
ReDim Preserve Mang(1 To BB)
Mang(BB) = LS
End If
LS = 0
End If
Next i
Cells(2 + k, 59) = WorksheetFunction.Max(Mang) & " Ngày"
Cells(2 + k, 60) = Round(WorksheetFunction.Average(Mang)) & " Ngày"
Erase Mang
End If
Next B
Next VT2
Next A
Next VT1
End Sub
Sub TruotPTCap()
On Error Resume Next
Range("BE2:BI28").ClearContents
Dim Duoi, Sh, Lh, i, j, k, Cau, VT1, VT2, Mang(), A, B, BB, LS
Duoi = Range("A" & Rows.Count).End(xlUp).Row - Sheets("TH").SpB1.Value
Set Lh = Range(Cells(Duoi - 1, 2), Cells(Duoi - 1, 28))
For Each VT1 In Lh
For A = 1 To Len(VT1)
For Each VT2 In Lh
For B = 1 To Len(VT2)
j = 0
tiep:
Cau = CStr(Mid(VT1(1 - j, 1), A, 1) & Mid(VT2(1 - j, 1), B, 1))
Set Sh = Range(Cells(Duoi - j, 29), Cells(Duoi - j, 55))
If WorksheetFunction.CountIf(Sh, CStr(Cau)) = False And WorksheetFunction.CountIf(Sh, StrReverse(CStr(Cau))) = False Then
j = j + 1
GoTo tiep
End If
If j > Sheets("TH").SpB2.Value Then
k = k + 1
Cau = CStr(Mid(VT1(2, 1), A, 1) & Mid(VT2(2, 1), B, 1))
Cells(1, 57) = "C" & ChrW(7847) & "u tr" & ChrW(432) & ChrW(7907) & "t Ph" & ChrW(7893) & " thông l" & ChrW(7897) & "n"
Cells(2, 57) = "Lô"
Cells(2, 58) = "Tr" & ChrW(432) & ChrW(7907) & "t dài"
Cells(2, 59) = "L" & ChrW(7883) & "ch s" & ChrW(7917)
Cells(2, 60) = "Average"
Cells(2, 61) = "Gi" & ChrW(7843) & "i"
If Left(Cau, 1) <> Right(Cau, 1) Then
Cells(2 + k, 57) = Cau & Left(Cau, 1)
Cells(2 + k, 61) = Cells(1, VT1.Column) & "." & A & " - " & Cells(1, VT2.Column) & "." & B
Else
Cells(2 + k, 57) = Cau
Cells(2 + k, 61) = Cells(1, VT1.Column) & "." & A & " - " & Cells(1, VT2.Column) & "." & B
End If
Cells(2 + k, 58) = j & " Ngày"
For i = 2 To Duoi - j
Cau = CStr(Mid(Cells(i, VT1.Column), A, 1) & Mid(Cells(i, VT2.Column), B, 1))
Set Sh = Range(Cells(i + 1, 29), Cells(i + 1, 55))
If WorksheetFunction.CountIf(Sh, CStr(Cau)) = False And WorksheetFunction.CountIf(Sh, StrReverse(CStr(Cau))) = False Then
LS = LS + 1
Else
If LS >= j Then
BB = BB + 1
ReDim Preserve Mang(1 To BB)
Mang(BB) = LS
End If
LS = 0
End If
Next i
Cells(2 + k, 59) = WorksheetFunction.Max(Mang) & " Ngày"
Cells(2 + k, 60) = Round(WorksheetFunction.Average(Mang)) & " Ngày"
Erase Mang
End If
Next B
Next VT2
Next A
Next VT1
End Sub

 

[dovanhoc84]

1-file đính kèm k có nên khó hiểu hơn
nhưng có 1 sub bạn k đưa ra là sub TruotPTCap
có lẽ dữ liệu lấy ở đó

2-Muốn tự động chạy khi mở thì vào VBE phần ThisWorkbook thêm đoạn code này

Private Sub Workbook_Open()
Call TruotPT
End Sub

3-Nếu muốn chạy = tay thì vào VBE chọn sub muốn chạy bấm F5, hoặc F8 để xem từng bước
Nếu muốn dùng nút bấn trên sheet thì tạo 1 textbox cũng được kích chuột phải chọn assign macro