Chào các anh (chị) hiện nay em có 1 đoạn mã VBA đã viết (nói chung là chạy tốt) nhưng do số liệu bảng tra quá dài (trên 50000 dòng) nên đoạn code phát huy không hiệu quả.
Chạy rất chậm và bị giật.
Nhờ các anh chị chỉnh lại giúp em đoạn code sau. Em xin chân thành cám ơn
Sub bienban()
On Error Resume Next
Dim sh1 As Worksheet ' Sheet DMCVNT
Dim Rng1 As Range
Dim STT_BBNT As Range
Dim STT_BB As Range
Dim STT_BBCV As Range
Dim VT_DTNT As Range
Dim VT_NDTCV As Range
Dim VT_TCV As Range
Dim VT_TCAD As Range
Dim VT_KTCV As Range
Dim sodongcp As Integer
Dim I As Integer
Dim bb As Integer
Dim SoBienBan As Integer
For bb = 1 To DMCVNT.Range("SoBB") 'So bien ban
Application.Interactive = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlManual
MBBNTNBCV.Copy before:=Sheets(bb)
Range("K5") = bb
'*******Dua so lieu tu bang Danh muc cong viec nghiem thu sang Bien ban nghiem thu ***************
Set STT_BB = Range("K5")
Set VT_DTNT = Sheets(bb).Cells.Find(What:="dtnt", After:=ActiveCell, LookIn:=xlComments, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
Set VT_TCV = Sheets(bb).Cells.Find(What:="TCV", After:=ActiveCell, LookIn:=xlComments, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
Set VT_NDTCV = Sheets(bb).Cells.Find(What:="NDKT", After:=ActiveCell, LookIn:=xlComments, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
Set VT_TCAD = Sheets(bb).Cells.Find(What:="TCAD", After:=ActiveCell, LookIn:=xlComments, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
Set VT_KTCV = Sheets(bb).Cells.Find(What:="KTCV", After:=ActiveCell, LookIn:=xlComments, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
Set Rng1 = Range(DMCVNT.[A6], DMCVNT.[A65500].End(xlUp))
Set STT_BBCV = Rng1.Find(STT_BB, , xlFormulas, xlWhole)
If STT_BBCV Is Nothing Then
VT_DTNT.Offset(0, 0).Font.ColorIndex = 3
Else
'Chen dong bien ban
Range(STT_BBCV.Offset(0, 17), STT_BBCV.End(xlDown).Offset(-1, 50)).Copy
VT_DTNT.Offset(1, 0).EntireRow.Insert
Range(STT_BBCV.Offset(0, 17), STT_BBCV.End(xlDown).Offset(-1, 50)).Copy
VT_TCV.Offset(1, 0).EntireRow.Insert
Range(STT_BBCV.Offset(0, 17), STT_BBCV.End(xlDown).Offset(-2, 50)).Copy
VT_TCAD.Offset(1, 0).EntireRow.Insert
Range(STT_BBCV.Offset(0, 17), STT_BBCV.End(xlDown).Offset(-1, 50)).Copy
VT_NDTCV.Offset(1, 0).EntireRow.Insert
'Copy so thu tu
Range(STT_BBCV.Offset(0, 1), STT_BBCV.End(xlDown).Offset(-1, 1)).Copy
VT_DTNT.Offset(1, 0).PasteSpecial (xlPasteValues)
VT_TCAD.Offset(1, 0).PasteSpecial (xlPasteValues)
VT_NDTCV.Offset(1, 0).PasteSpecial (xlPasteValues)
VT_TCV.Offset(1, 0).PasteSpecial (xlPasteValues)
'Ma hieu cong viec
Range(STT_BBCV.Offset(0, 2), STT_BBCV.End(xlDown).Offset(-2, 2)).Copy
VT_TCAD.Offset(1, -2).PasteSpecial (xlPasteValues)
VT_TCAD.Offset(1, 14).PasteSpecial (xlPasteValues)
VT_NDTCV.Offset(1, -3).PasteSpecial (xlPasteValues)
'Copy ten cong viec
Range(STT_BBCV.Offset(0, 3), STT_BBCV.End(xlDown).Offset(-1, 3)).Copy
VT_DTNT.Offset(1, 1).PasteSpecial (xlPasteValues)
VT_TCV.Offset(1, 1).PasteSpecial (xlPasteValues)
VT_NDTCV.Offset(1, 1).PasteSpecial (xlPasteValues)
VT_TCAD.Offset(1, 1).PasteSpecial (xlPasteValues)
'Copy don vi
Range(STT_BBCV.Offset(0, 4), STT_BBCV.End(xlDown).Offset(-1, 4)).Copy
VT_TCV.Offset(1, 8).PasteSpecial (xlPasteValues)
'Khoi luong cong viec
Range(STT_BBCV.Offset(0, 5), STT_BBCV.End(xlDown).Offset(-2, 5)).Copy
VT_TCV.Offset(1, 9).PasteSpecial (xlPasteValues)
Range(STT_BBCV.Offset(0, 6), STT_BBCV.End(xlDown).Offset(-2, 6)).Copy
VT_TCV.Offset(1, 11).PasteSpecial (xlPasteValues)
'Ke bang noi dung kiem tra
Range(VT_NDTCV.Offset(0, 1), VT_TCV.Offset(-3, 12)).Select
End If
'Dien ki hieu nhan biet noi dung kiem tra ten cong viec
For I = 11 To 500
If Cells(I, "A") <> "" Then
Cells(I, "B") = ":" & Cells(I, "A")
End If
Next I
'***** Chen cac noi dung tieu chuan va noi dung kiem tra cong viec ******
' Khai báo
Range("B7").End(xlDown).Select
Dim Sh As Worksheet, Rng As Range, sRng As Range, XX As Range
Set Sh = Workbooks("TCVN.xla").Worksheets("TCNTCV")
Set Rng = Sh.Range(Sh.[C2], Sh.[C65500].End(xlUp))
'Tra du lieu tao bang CMPT
Do Until Selection = ""
Set XX = Selection
Set sRng = Rng.Find(XX, , xlFormulas, xlWhole)
If sRng Is Nothing Then
Selection.Font.ColorIndex = 3
Selection.Offset(1, 0).Select
Selection.EntireRow.Insert
Selection.End(xlDown).Select
Else
Range(sRng.Offset(0, 0), sRng.End(xlDown).Offset(-1, 0)).EntireRow.Copy
Selection.Offset(1, -1).Insert Shift:=xlDown
Selection.ClearContents
Selection.End(xlDown).Select
End If
Loop
Application.CutCopyMode = False
Range("A1").Select
Sheets(bb).Name = "NTNBCV" & bb
'Dinh dang bang bieu
Dim x As Integer
For x = 11 To 500
If Cells(x, "A") <> "" Then
Range(Cells(x, "D"), Cells(x, "P")).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
.WrapText = True
.MergeCells = False
.Font.Bold = True
.Font.Italic = True
End With
End If
If Cells(x, "R") <> "" Then
Cells(x, "D").Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.WrapText = True
'.Font.Bold = True
.Font.Italic = True
End With
Range(Cells(x, "E"), Cells(x, "P")).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = True
.MergeCells = True
'.Font.Bold = True
.Font.Italic = True
End With
End If
'Ke bang khoi luong
Range(VT_TCV.Offset(1, 0), VT_KTCV.Offset(-2, 0)).Select
With Selection
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
Selection.NumberFormat = "General"
'Ke chan bang noi dung nghiem thu
Range(VT_TCV.Offset(-4, 0), VT_TCV.Offset(-4, 12)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("D1").Select
Next x
'Tao bien ban tiep theo
Next bb
Application.Interactive = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Sheets(1).Select
Set STT_BB = Nothing
Set VT_DTNT = Nothing
Set VT_TCV = Nothing
Set VT_NDTCV = Nothing
Set VT_TCAD = Nothing
Set Rng1 = Nothing
Set STT_BBCV = Nothing
Set Sh = Nothing
Set Rng = Nothing
Set XX = Nothing
Set sRng = Nothing
End Sub
