Need Help in Speeding up current VBA

[Shums]

Good Day Experts,

I have below code which copies data from numerous sheets in current workbook and update my summary sheet.

Problem is it little bit slow, do you guys have any better and faster advice.

Sub UpdateSummary()
Dim Ws As Worksheet
Dim lastRow As Long, LR As Long
Dim Col As Long
Dim sh As Integer
Dim c As String, d As String, e As String, f As String, g As String, i As String, j As String, k As String, l As String

Call FunctionalityOff
Set Ws = Worksheets("SummarySheet")
Application
For sh = 2 To 11
    With Sheets(sh)
    lastRow = Sheets(sh).Range("C" & Rows.Count).End(xlUp).Row
    If Sheets(sh).Name <> Ws.Name Then
        For a = 2 To lastRow
            For Col = 3 To 3
                If .Cells(a, Col) <> "" Then
                    c = .Cells(a, 3)
                    d = .Cells(a, 4)
                    e = .Cells(a, 5)
                    f = .Cells(a, 6)
                    g = .Cells(a, 7)
                    i = .Cells(a, 9)
                    j = .Cells(a, 10)
                    k = .Cells(a, 11)
                    l = .Cells(a, 12)
                        With Ws
                            .Range("C" & .Range("C" & .Rows.Count).End(xlUp).Row + 1).Value = c
                            .Range("D" & .Range("D" & .Rows.Count).End(xlUp).Row + 1).Value = d
                            .Range("E" & .Range("E" & .Rows.Count).End(xlUp).Row + 1).Value = e
                            .Range("F" & .Range("F" & .Rows.Count).End(xlUp).Row + 1).Value = f
                            .Range("G" & .Range("G" & .Rows.Count).End(xlUp).Row + 1).Value = g
                            .Range("I" & .Range("I" & .Rows.Count).End(xlUp).Row + 1).Value = i
                            .Range("J" & .Range("J" & .Rows.Count).End(xlUp).Row + 1).Value = j
                            .Range("K" & .Range("K" & .Rows.Count).End(xlUp).Row + 1).Value = k
                            .Range("L" & .Range("L" & .Rows.Count).End(xlUp).Row + 1).Value = l
                        End With
                End If
            Next
        Next
    End If
    End With
Next
Call FunctionalityOn
End Sub

For Speeding Up I have which doesn't help :

Sub FunctionalityOff()
    With Application
        .ScreenUpdating = False
        .DisplayStatusBar = False
        .StatusBar = False
        .EnableEvents = False
        .Calculation = xlManual
    End With
End Sub

Sub FunctionalityOn()
    With Application
        .ScreenUpdating = True
        .DisplayStatusBar = True
        .StatusBar = True
        .EnableEvents = True
        .Calculation = xlAutomatic
    End With
End Sub

 

[jim may]

Why use line: For Col = 3 To 3

and the corresponding or related Next statement

Why not substitute for your For Col = 3 to 3 with: Col = 3 and remove the related next.

 

[Shums]

Why use line: For Col = 3 To 3

and the corresponding or related Next statement

Why not substitute for your For Col = 3 to 3 with: Col = 3 and remove the related next.

Thanks Jim. It did helped a bit.

 

[wideboydixon]

Your code seems to suggest that the last row in each column might be different so I catered for that. This might run quicker:

Sub UpdateSummary()

Dim summarySheet As Worksheet
Dim lastRow As Long
Dim thisSheet As Long
Dim thisCol As Long
Dim thisRow As Long
Dim lastRows(12) As Long

Call FunctionalityOff

Set summarySheet = Worksheets("SummarySheet")
For c = 3 To 12
    lastRows(c) = summarySheet.Cells(Ws.Rows.Count, 3).End(xlUp).Row + 1
Next c

For thisSheet = 2 To 11
    If thisSheet <> summarySheet.Index Then
        With Sheets(thisSheet)
            lastRow = .Cells(.Rows.Count, 3).End(xlUp).Row
            For thisRow = 2 To lastRow
                If .Cells(thisRow, 3) <> "" Then
                    For thisCol = 3 To 12
                        If thisCol <> 8 Then
                            summarySheet.Cells(lastRows(thisCol), thisCol) = .Cells(thisRow, thisCol)
                            lastRows(thisCol) = lastRows(thisCol) + 1
                        End If
                    Next thisCol
                End If
            Next thisRow
        End With
    End If
Next thisSheet

Call FunctionalityOn

End Sub

WBD

 

[JLGWhiz]

Give this a shot

Sub UpdateSummary()
Dim Ws As Worksheet
Dim lastRow As Long, LR As Long, a As Long
Dim Col As Long
Dim sh As Integer
Call FunctionalityOff
Set Ws = Worksheets("SummarySheet")
Application 'I don't know what this is so I left it.
For sh = 2 To 11
    With Sheets(sh)
        lastRow = .Range("C" & Rows.Count).End(xlUp).Row
        If .Name <> Ws.Name Then
            For a = 2 To lastRow
                For Col = 3 To 12
                    If .Cells(a, Col) <> "" Then
                        With Ws
                            .Cells(Rows.Count, a).End(xlUp)(2).Value = Sheets(sh).Cells(a, Col)
                        End With
                    End If
                Next
            Next
        End If
    End With
Next
Call FunctionalityOn
End Sub

 

[wideboydixon]

Note that Column "H" isn't copied in the original code.

WBD

 

[Shums]

Your code seems to suggest that the last row in each column might be different so I catered for that. This might run quicker:

Sub UpdateSummary()

Dim summarySheet As Worksheet
Dim lastRow As Long
Dim thisSheet As Long
Dim thisCol As Long
Dim thisRow As Long
Dim lastRows(12) As Long

Call FunctionalityOff

Set summarySheet = Worksheets("SummarySheet")
For c = 3 To 12
    lastRows(c) = summarySheet.Cells(Ws.Rows.Count, 3).End(xlUp).Row + 1 'changed ws to summarySheet
Next c

For thisSheet = 2 To 11
    If thisSheet <> summarySheet.Index Then
        With Sheets(thisSheet)
            lastRow = .Cells(.Rows.Count, 3).End(xlUp).Row
            For thisRow = 2 To lastRow
                If .Cells(thisRow, 3) <> "" Then
                    For thisCol = 3 To 12
                        If thisCol <> 8 Then
                            summarySheet.Cells(lastRows(thisCol), thisCol) = .Cells(thisRow, thisCol)
                            lastRows(thisCol) = lastRows(thisCol) + 1
                        End If
                    Next thisCol
                End If
            Next thisRow
        End With
    End If
Next thisSheet

Call FunctionalityOn

End Sub

WBD

This worked perfectly.

Thanks a lot WBD

 

[Shums]

Give this a shot

Sub UpdateSummary()
Dim Ws As Worksheet
Dim lastRow As Long, LR As Long, a As Long
Dim Col As Long
Dim sh As Integer
Call FunctionalityOff
Set Ws = Worksheets("SummarySheet")
Application 'I don't know what this is so I left it.
For sh = 2 To 11
    With Sheets(sh)
        lastRow = .Range("C" & Rows.Count).End(xlUp).Row
        If .Name <> Ws.Name Then
            For a = 2 To lastRow
                For Col = 3 To 12
                    If .Cells(a, Col) <> "" Then
                        With Ws
                            .Cells(Rows.Count, a).End(xlUp)(2).Value = Sheets(sh).Cells(a, Col)
                        End With
                    End If
                Next
            Next
        End If
    End With
Next
Call FunctionalityOn
End Sub

JLGWhiz.

I don't understand what this code did, but it messed up the whole columns format. Sorry buddy.

 

[wideboydixon]

This worked perfectly.

Thanks a lot WBD

No problem. Good catch on the sheet reference - I forgot that one when I was renaming for clarity. It's late and I've had a beer. What can I say?

WBD