VBA script to format an Excel sheet

Question

I'm making an app in Excel-VBA, but when I have more than 50,000 records, my code runs very slow and the formatting takes about 33 seconds.

Application.Interactive = False
Application.EnableEvents = False
Application.ScreenUpdating = False
'--------------- Tao Bien ------------------------------------------
Dim Dulieu() As Variant
Dim lastrow As Integer
Dim lastrowSC As Integer
Dim i, j As Integer
Dim NoDk, CoDk As Double
Dim PSNo As Double
Dim PSCo As Double
Dim NoCk As Double
Dim CoCk As Double
Dim TempArray() As Variant
Dim TheRange As Range
Dim Size As Integer
Dim TempArrayDao() As Variant
Dim lastrowTK As Integer
Dim TaiKhoan() As Variant
Dim FromDate As Date
Dim ToDate As Date


'--------------------Do Toc Do--------------------------------------
Dim Starttime As Double
Dim Code1 As Double
Dim Code2 As Double
Dim Code3 As Double
Dim Code4 As Double
Dim Code5 As Double
Dim Code6 As Double
Dim Code7 As Double
Starttime = Timer




'--------------- Xong Tao Bien --------------------------------------
NoDk = 0
CoDk = 0
PSNo = 0
PSCo = 0
NoCk = 0
CoCk = 0
lastrow = Sheet8.Cells(Rows.Count, "I").End(xlUp).Row

'Them so du dau ky----------------------------------------------------

lastrowTK = Sheet7.Cells(Rows.Count, "A").End(xlUp).Row
TaiKhoan = Sheet7.Range("A2:H" & lastrowTK)


For i = LBound(TaiKhoan) To UBound(TaiKhoan)
    If Sheet26.Cells(4, 4).Text = TaiKhoan(i, 1) Then
        NoDk = TaiKhoan(i, 3)
        CoDk = TaiKhoan(i, 4)
        Sheet26.Cells(5, 3).Value = "Tên tài kho" & ChrW(7843) & "n : " & TaiKhoan(i, 2)
        Exit For
    End If

Next

Code1 = Round(Timer - Starttime, 2)
'----------------------------------------------------------------------
Dim NoCongDon As Double
Dim CoCongDon As Double

Sheet26.Select
' Dua Du lieu vao Array Dulieu
Dulieu = Sheet8.Range("G2:N" & lastrow).Value
FromDate = Sheet26.Cells(6, 3).Value
ToDate = Sheet26.Cells(7, 3).Value
Size = 1
ReDim TempArray(1 To 6, 1 To Size)
Dim tk As String
tk = Sheet26.Cells(4, 4).Text
For i = 1 To UBound(Dulieu)
    If ((StrComp(Left(tk, Len(Trim(tk))), Left(Dulieu(i, 6), Len(Trim(tk))), vbTextCompare) = 0) Or _
    (StrComp(Left(tk, Len(Trim(tk))), Left(Dulieu(i, 7), Len(Trim(tk))), vbTextCompare) = 0)) Then

        If (StrComp(Left(tk, Len(Trim(tk))), Left(Dulieu(i, 6), Len(Trim(tk))), vbTextCompare) = 0) Then
            If Dulieu(i, 3) < FromDate Then
            NoCongDon = NoCongDon + Dulieu(i, 8)
            ElseIf Dulieu(i, 3) = FromDate Or Dulieu(i, 3) <= ToDate Then
            TempArray(1, Size) = Dulieu(i, 1)
            TempArray(2, Size) = Dulieu(i, 3)
            TempArray(3, Size) = Dulieu(i, 5)
            TempArray(4, Size) = Dulieu(i, 7)
            TempArray(5, Size) = Dulieu(i, 8)
            Size = Size + 1
            ReDim Preserve TempArray(1 To 6, 1 To Size)
            End If
        Else
            If Dulieu(i, 3) < FromDate Then
            CoCongDon = CoCongDon + Dulieu(i, 8)
            ElseIf Dulieu(i, 3) = FromDate Or Dulieu(i, 3) <= ToDate Then
            TempArray(1, Size) = Dulieu(i, 1)
            TempArray(2, Size) = Dulieu(i, 3)
            TempArray(3, Size) = Dulieu(i, 5)
            TempArray(4, Size) = Dulieu(i, 6)
            TempArray(6, Size) = Dulieu(i, 8)
            Size = Size + 1
            ReDim Preserve TempArray(1 To 6, 1 To Size)
            End If
        End If


    End If
Next i

Code2 = Round(Timer - Starttime, 2)
'Dao lai Array Tam
ReDim TempArrayDao(1 To Size, 1 To 6)
For i = 1 To Size
    For j = 1 To 6
        TempArrayDao(i, j) = TempArray(j, i)
    Next
Next
k = UBound(TempArrayDao) + 14

'Add value to my sheet
Set TheRange = Sheet26.Range("A15:F" & k)
TheRange.Value = TempArrayDao

Format my sheet, is take me 33s to format my sheet, i don't know why ..

With Sheet26
    With .Range("A14:F" & k + 1)
        .ClearFormats
        .Borders.LineStyle = xlContinuous
     End With
Code4 = Round(Timer - Starttime, 2) ' code4 is 0.4 s
    With .Range("C14:C" & k)
        .WrapText = True
        .Rows.AutoFit
        .VerticalAlignment = xlCenter
    End With

Code5 = Round(Timer - Starttime, 2) 'code5 is 13,14s
    .Range("A14:B" & k).HorizontalAlignment = xlCenter
    .Range("A14:B" & k).VerticalAlignment = xlCenter

    With .Range("D14:D" & k)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .NumberFormat = "@"
    End With

    With .Range("E14:F" & k + 1)
        .NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
        .VerticalAlignment = xlCenter

    End With
    .Range("C" & k & ":C" & k + 1).HorizontalAlignment = xlCenter
    .Range("B14:B" & k).NumberFormat = "dd/mm/yyyy"

Code6 = Round(Timer - Starttime, 2) ' code6 is 33,97 s
End With


With Sheet26.Range("A" & k & ":F" & k + 1)
    .Interior.ThemeColor = xlThemeColorDark2
    .Font.Bold = True
End With
ReDim Dulieu(0, 0) As Variant
ReDim TempArray(0, 0) As Variant
Set TheRange = Nothing
ReDim TempArrayDao(0, 0) As Variant
ReDim TaiKhoan(0, 0) As Variant
Application.Interactive = True
Application.EnableEvents = True
Application.ScreenUpdating = True

Your title should describe what your code is doing instead of what the problem is. It looks like you are trying to copy a range from Sheet8 to Sheet26 and then format columns and cells the pasted range. Could you post the workbook in a drop-box so we can get a better understanding of its structure and purpose? — Mark Fitzgerald, Oct 27, 2015 at 8:05
I couldn't download your workbook. Is the Master sheet formatted? Have you tried a simple copy/paste from Master to destination? — Mark Fitzgerald, Oct 27, 2015 at 9:56
111 took 7.39s to run. Taking out the Vertical alignment (4 places) reduced it to 3.21. Also taking out the Horizontal alignment got it down to 2.16. I'm sure there improvements to be made while still keeping your format requirements. Let me think on it for a day. — Mark Fitzgerald, Oct 28, 2015 at 11:33

Mark Fitzgerald · Accepted Answer · 2015-10-29 07:40:53Z

I thought about applying filters to your KTSC data but, working through your code, I realised that wasn't an option due to valid rows coming from both columns L and M.

The first part of your code using arrays to juggle the data is quite fast and I can't see any significant speed gains by changing its logic. I did however move your With Sheets26 from within the formatting code to just below Dulieu = Sheet8.Range("G2:N" & lastrow).Value because that was the last call to any other sheet. I also moved your End With as far down your code as seemed logical.

Your formatting section had repeated calls to .VerticalAlignment = xlCenter and .HorizontalAlignment = xlCenter for different ranges. It seems that formatting 4 or 6 columns is just as fast as formatting 1. So I changed to code to use each formatting command once only. I did try formatting a single row (14) on SỔ CÁI and then copying the formats to all other rows and picked up about 0.2s

With 111 in D4 of SỔ CÁI this code runs for me in 1.41s compared with the 7.39s I mentioned in comments.

So:

try to use logic such that formatting commands are applied once to the broadest range possible
Use With..EndWith constructs in the broadest span possible. It's OK to reference other objects/sheets/ranges explicitly within the construct.

Here's the code which should run in < 6s on your machine:

Sub InSoCai()

'Application.Interactive = False I don't think there is any speed gain using this
Application.EnableEvents = False
Application.ScreenUpdating = False
'--------------- Tao Bien ------------------------------------------
Dim Dulieu() As Variant
Dim lastrow As Integer
Dim lastrowSC As Integer
Dim i As Integer
Dim j As Integer
Dim NoDk As Double
Dim CoDk As Double
Dim PSNo As Double
Dim PSCo As Double
Dim NoCk As Double
Dim CoCk As Double
Dim TempArray() As Variant
Dim TheRange As Range
Dim Size As Integer
Dim TempArrayDao() As Variant
Dim lastrowTK As Integer
Dim TaiKhoan() As Variant
Dim FromDate As Date
Dim ToDate As Date


'--------------------Do Toc Do--------------------------------------
Dim Starttime As Double
Dim Code1 As Double
Dim Code2 As Double
Dim Code3 As Double
Dim Code4 As Double
Dim Code5 As Double
Dim Code6 As Double
Dim Code7 As Double
Starttime = Timer




'--------------- Xong Tao Bien --------------------------------------
NoDk = 0
CoDk = 0
PSNo = 0
PSCo = 0
NoCk = 0
CoCk = 0
lastrow = Sheet8.Cells(Rows.Count, "I").End(xlUp).Row

'Them so du dau ky----------------------------------------------------

lastrowTK = Sheet7.Cells(Rows.Count, "A").End(xlUp).Row
TaiKhoan = Sheet7.Range("A2:H" & lastrowTK)


For i = LBound(TaiKhoan) To UBound(TaiKhoan)
    If Sheet26.Cells(4, 4).Text = TaiKhoan(i, 1) Then
        NoDk = TaiKhoan(i, 3)
        CoDk = TaiKhoan(i, 4)
        Sheet26.Cells(5, 3).Value = "Tên tài kho" _
            & ChrW(7843) & "n : " & TaiKhoan(i, 2)
        Exit For
    End If
Next

Code1 = Round(Timer - Starttime, 2)
'----------------------------------------------------------------------
Dim NoCongDon As Double
Dim CoCongDon As Double

' Dua Du lieu vao Array Dulieu
Dulieu = Sheet8.Range("G2:N" & lastrow).Value
With Sheet26
    FromDate = .Cells(6, 3).Value 'Does this date ever change
    ToDate = .Cells(7, 3).Value
    Size = 1
    ReDim TempArray(1 To 6, 1 To Size)
    Dim tk As String
    tk = .Cells(4, 4).Text
    For i = 1 To UBound(Dulieu)
        If StrComp(Left(tk, Len(Trim(tk))), _
            Left(Dulieu(i, 6), Len(Trim(tk))), vbTextCompare) = 0 _
        Or StrComp(Left(tk, Len(Trim(tk))), _
            Left(Dulieu(i, 7), Len(Trim(tk))), vbTextCompare) = 0 Then

            If (StrComp(Left(tk, Len(Trim(tk))), _
                Left(Dulieu(i, 6), Len(Trim(tk))), vbTextCompare) = 0) Then
                If Dulieu(i, 3) < FromDate Then
                    NoCongDon = NoCongDon + Dulieu(i, 8)
                ElseIf Dulieu(i, 3) = FromDate Or Dulieu(i, 3) <= ToDate Then
                    TempArray(1, Size) = Dulieu(i, 1)
                    TempArray(2, Size) = Dulieu(i, 3)
                    TempArray(3, Size) = Dulieu(i, 5)
                    TempArray(4, Size) = Dulieu(i, 7)
                    TempArray(5, Size) = Dulieu(i, 8)
                    Size = Size + 1
                    ReDim Preserve TempArray(1 To 6, 1 To Size)
                End If
            Else
                If Dulieu(i, 3) < FromDate Then
                    CoCongDon = CoCongDon + Dulieu(i, 8)
                ElseIf Dulieu(i, 3) = FromDate Or Dulieu(i, 3) <= ToDate Then
                    TempArray(1, Size) = Dulieu(i, 1)
                    TempArray(2, Size) = Dulieu(i, 3)
                    TempArray(3, Size) = Dulieu(i, 5)
                    TempArray(4, Size) = Dulieu(i, 6)
                    TempArray(6, Size) = Dulieu(i, 8)
                    Size = Size + 1
                    ReDim Preserve TempArray(1 To 6, 1 To Size)
                End If
            End If


        End If
    Next i

    Code2 = Round(Timer - Starttime, 2)
    'Dao lai Array Tam
    ReDim TempArrayDao(1 To Size, 1 To 6)
    For i = 1 To Size
        For j = 1 To 6
            TempArrayDao(i, j) = TempArray(j, i)
        Next
    Next
    '--------------Chep Footer --------------------
    lastrowSC = .Cells(Rows.Count, "A").End(xlUp).Row
    Sheet26.Range(.Cells(lastrowSC - 7, 1), .Cells(lastrowSC, 6)).Cut _
    Sheet26.Range(.Cells(UBound(TempArrayDao) + 16, 1), .Cells(UBound(TempArrayDao) + 16 + 7, 13))

    .Range(.Cells(14, 1), .Cells(UBound(TempArrayDao) + 16, 6)).Clear
    If (UBound(TempArrayDao) + 16 + 8 < lastrowSC) Then
        .Range(.Cells(UBound(TempArrayDao) + 16 + 8, 1), .Cells(lastrowSC, 6)).Clear
    End If
    Code3 = Round(Timer - Starttime, 2)

    '--------------Xong Chep Footer ---------------
    k = UBound(TempArrayDao) + 14


    'Them du lieu vao So cai
    Set TheRange = .Range("A15:F" & k)
    TheRange.Value = TempArrayDao

    '--------------- Giai phong Bien ------------------------------------------
    ReDim Dulieu(0, 0) As Variant
    ReDim TempArray(0, 0) As Variant
    Set TheRange = Nothing
    ReDim TempArrayDao(0, 0) As Variant
    ReDim TaiKhoan(0, 0) As Variant

'--------------- Xong Tao Bien --------------------------------------
'Format lai bang Cong No
    With .Range("A14:F14")
        .ClearFormats
        .Borders.LineStyle = xlContinuous
        .VerticalAlignment = xlCenter
    End With
    With .Range("A14:D14")
       .HorizontalAlignment = xlCenter
    End With
    With .Range("E14:F14")
       .NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
    End With
    .Range("B14:B14").NumberFormat = "dd/mm/yyyy"
    .Range("C14:C14").WrapText = True
    .Range("D14:D14").NumberFormat = "@"
    .Range("A14:F14").Copy
    .Range("A14:F" & k).PasteSpecial xlPasteFormats
    With .Range("A" & k & ":F" & k + 1)
        .Interior.ThemeColor = xlThemeColorDark2
        .Font.Bold = True
    End With
    .Range("C" & k).Value = "T" & ChrW(7893) & "ng phát sinh"
    .Range("C" & k + 1).Value = "Cu" & ChrW(7889) & "i k" & ChrW(7923)
    .Cells(14, 3).Value = "Sô d" & ChrW(432) & " " & ChrW(273) & ChrW(7847) & "u k" & ChrW(7923)
    .Cells(8, 5).Value = NoDk
    .Cells(8, 6).Value = CoDk
    .Cells(14, 5).Value = NoDk
    .Cells(14, 6).Value = CoDk
    If NoDk > 0 Then
        NoDk = NoDk + NoCongDon - CoCongDon
        CoDk = 0
    Else
        CoDk = CoDk + CoCongDon - NoCongDon
        NoDk = 0
    End If
    .Range("E" & k).FormulaR1C1 = "=SUBTOTAL(9,R[-" & Size - 1 & "]C:R[-1]C)"
    .Range("F" & k).FormulaR1C1 = "=SUBTOTAL(9,R[-" & Size - 1 & "]C:R[-1]C)"
    PSNo = .Range("E" & k).Value
    PSCo = .Range("F" & k).Value
    .Cells(8, 5).Value = NoDk
    .Cells(8, 6).Value = CoDk
    .Cells(9, 5).Value = PSNo
    .Cells(9, 6).Value = PSCo
    If NoDk > 0 Then
        NoDk = NoDk + NoCongDon - CoCongDon
        CoDk = 0
    Else
        CoDk = CoDk + CoCongDon - NoCongDon
        NoDk = 0
    End If
    NoCk = NoDk - CoDk + PSNo - PSCo
    If NoCk > 0 Then
        CoCk = 0
    Else
        CoCk = -NoCk
        NoCk = 0
    End If
    .Cells(10, 5).Value = NoCk
    .Cells(10, 6).Value = CoCk
    .Range("E" & k + 1).Value = NoCk
    .Range("F" & k + 1).Value = CoCk
    .Select
    .Cells(1, 1).Select
End With

Code7 = Round(Timer - Starttime, 2)

Application.Interactive = True
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Thank @Mark Fitzgerald , It ran in 9s in my machine, this code ran 4,5s : .Range(.Cells(14, 1), .Cells(UBound(TempArrayDao) + 16, 6)).Clear If (UBound(TempArrayDao) + 16 + 8 < lastrowSC) Then .Range(.Cells(UBound(TempArrayDao) + 16 + 8, 1), .Cells(lastrowSC, 6)).Clear End If — Trương Ngọc Đăng Khoa, Nov 2, 2015 at 5:07
Thanks for the Thanks. It makes me happy to be able to help people here. — Mark Fitzgerald, Nov 3, 2015 at 10:30

Stack Exchange Network

VBA script to format an Excel sheet

1 Answer 1

Your Answer

Not the answer you're looking for? Browse other questions tagged
performance
vba
excel
or ask your own question.

Hot Network Questions

VBA script to format an Excel sheet

1 Answer 1

Your Answer

Sign up or log in

Post as a guest

Not the answer you're looking for? Browse other questions tagged performancevbaexcel or ask your own question.

Related

Hot Network Questions

Not the answer you're looking for? Browse other questions tagged
performance
vba
excel
or ask your own question.