Tăng tốc cho code
Đoạn code của em nhu sau, nho các anh xem hộ và khắc phục cho nó chạy nhanh hon.em co file du liệu kèm theo.
Option Explicit
Option Base 1
Public dir, ten1, ten2, ten3 As String
Sub ten()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim path1, path2, dir, dir1, dir2 As String
Dim i, j, r, crc, tctmax, tothua As Integer
Dim Msg, x, WorkbookIsOpen As String
Dim a, b, them As Integer
Dim CreateFileList As Variant
Dim FileFilter As String, IncludeSubFolder As Boolean
Dim FileList() As String, FileCount As Long
dir = "D:\txt\"
CreateFileList = ""
Erase FileList
If FileFilter = "" Then FileFilter = "*.xls*"
With Application.FileSearch
.NewSearch
.LookIn = dir
.Filename = FileFilter
.SearchSubFolders = IncludeSubFolder
.FileType = msoFileTypeAllFiles
If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) = 0 Then Exit Sub
ReDim FileList(.FoundFiles.Count)
For FileCount = 1 To .FoundFiles.Count
FileList(FileCount) = .FoundFiles(FileCount)
Next FileCount
MsgBox "Tæng sè file lµ: " & FileCount - 1, , "files"
.FileType = msoFileTypeExcelWorkbooks
End With
CreateFileList = FileList
Erase FileList
ten1 = InputBox("nhËp tªn 1: ", "ten 1")
ten2 = InputBox("nhap ten 2: ", "ten 2 ")
ten2 = InputBox("nhËp tªn 3: ", "ten 3")
dir2 = "d:\tenkhac\"
On Error Resume Next
For i = 1 To FileCount - 1
path1 = dir & "TXT_" & Format(i, "") & ".xls"
path2 = dir2 & "ten_" & Format(i, "") & ".xls"
For j = 1 To FileCount - 1
Const xlInfo = -4129
On Error Resume Next
Workbooks(path1).Activate
If Err = 0 Then
MsgBox "File TXT ®ang më", , "txt "
ActiveWorkbook.Close
Else
WorkbookIsOpen = False
End If
Next j
Workbooks.Open Filename:=path1
ActiveWorkbook.SaveAs Filename:=path2
Workbooks(path1).Close
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.PaperSize = xlPaperA4
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
End With
ActiveWorkbook.Worksheets("Sheet1").Select
Rows("1:4").Select
Selection.Insert Shift:=xlDown
Range(Cells(1, 1), Cells(1, 7)).Select: Selection.Merge
Range(Cells(2, 1), Cells(2, 7)).Select: Selection.Merge
Range(Cells(3, 1), Cells(3, 7)).Select: Selection.Merge
Range(Cells(1, 1), Cells(3, 1)).Select: Selection.HorizontalAlignment = xlVAlignCenter
Cells(1, 1).Select
With Selection.Font
.Name = ".VnArial NarrowH"
.Size = 12
End With
Cells(2, 1).Select
With Selection.Font
.Name = ".VnAvant"
.Size = 12
.Bold = True
End With
Cells(3, 1).Select
With Selection.Font
.Name = ".VnArial NarrowH"
.Size = 10
End With
Cells(1, 1) = "b¶ng thèng kª DT"
Cells(2, 1) = "Xa : " & ten1 & " - huyen : " & ten2 & " - tinh :" & ten3
Cells(3, 1) = "So hieu: " & Cells(5, 1).Value
Cells(4, 1) = "STT": Cells(4, 2) = "TCT": Cells(4, 3) = "DT": Cells(4, 4) = "Ma dat": Cells(4, 5) = "Ten": Cells(4, 6) = "them": Cells(4, 7) = "bo"
Range(Cells(4, 1), Cells(4, 6)).Select
With Selection.Font
.Name = ".vnarial"
.Size = 11
.ColorIndex = 5
End With
Range(Cells(5, 1), Cells(5, 7)).Select.Font.Name = ".vnarial"
Range(Cells(5, 1), Cells(5, 7)).Font.Size = 10
crc = Cells(1, 1).End(xlDown).Row
tctmax = Application.WorksheetFunction.Max(Range(Cells(5, 2), Cells(crc, 2)))
For r = 5 To crc
If Cells(r, 2).Value = tctmax Then
tothua = Range(Cells(5, 2), Cells(r, 2)).Rows.Count
End If
Next r
For r = 5 To (tothua + 5)
Cells(r, 1) = r - 4
Next r
Range(Cells(tothua + 5, 1), Cells(crc, 1)).ClearContents
Range(Cells(5, 6), Cells(crc, 6)).ClearContents
them = crc + tothua * 0.2 + 1
Range(Cells(6, 1), Cells(them, 7)).Select
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = 5
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = 5
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = 5
End With
Range(Cells(4, 1), Cells(them, 7)).Select
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 3
End With
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 3
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 3
End With
Range(Cells(4, 1), Cells(4, 7)).Select
With Selection.Borders
.LineStyle = xlContinuous
End With
Range("A:A").ColumnWidth = 5: Range("B:B").ColumnWidth = 5: Range("C:C").ColumnWidth = 9.86
Range("D
").ColumnWidth = 9.14: Range("E:E").ColumnWidth = 23.14: Range("F:F").ColumnWidth = 27
Range("G:G").ColumnWidth = 11
Range("C:C").NumberFormat = "0.0"
Range(Cells(1, 1), Cells(them + 10, 7)).RowHeight = 20
Range(Cells(1, 1), Cells(them + 10, 7)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Cells(them, 1) = "Tong cong ="
Cells(them, 3) = Application.WorksheetFunction.Sum(Range(Cells(5, 3), Cells(them - 1, 4)))
Cells(them, 4).Select
Selection.HorizontalAlignment = xlLeft
Selection = "m2"
With Selection.Characters(Start:=2, Length:=1).Font
.Superscript = True
End With
Range(Cells(them, 1), Cells(them, 4)).Select
With Selection.Font
.Name = ".VnArial"
.Size = 10
.Bold = True
.HorizontalAlignment = xlLeft
End With
Cells(1, 8).Select
ActiveWorkbook.Close savechanges:=True
Next i
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Workbooks("sofcode.xls").Save
Application.ScreenUpdating = True
End Sub
