Tidy up VBA Code

[danny8890]

Hi All,

I've got a piece of VBA that I've developed that works perfectly fine apart from being slow why has to work on a lot of data at once.

I know there will be a way to tidy this up and make it smaller however its out of my skill range at the moment.

I would greatly appreciate anyone who can tidy this up so it runs faster

Sub Button1_Click()
Dim i, lastRow
lastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Application.DisplayAlerts = False

Range("G2:G" & lastRow).Select
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("G2"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False
For i = 2 To lastRow
If Sheets("Sheet1").Cells(i, "A").Value Like "*SIM*" Then
Sheets("Sheet1").Cells(i, "A").Columns("A:H").Copy Destination:=Sheets("SIM").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
For i = 2 To lastRow
If Sheets("Sheet1").Cells(i, "A").Value Like "*SSN*" Then
Sheets("Sheet1").Cells(i, "A").Columns("A:H").Copy Destination:=Sheets("SIM").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
For i = 2 To lastRow
If Sheets("Sheet1").Cells(i, "A").Value Like "*Sim*" Then
Sheets("Sheet1").Cells(i, "A").Columns("A:H").Copy Destination:=Sheets("SIM").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
For i = 2 To lastRow
If Sheets("Sheet1").Cells(i, "A").Value Like "*Duplicate*" Then
Sheets("Sheet1").Cells(i, "A").Columns("A:H").Copy Destination:=Sheets("Duplicate Account").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
For i = 2 To lastRow
If Sheets("Sheet1").Cells(i, "A").Value Like "*Dispute*" Then
Sheets("Sheet1").Cells(i, "A").Columns("A:H").Copy Destination:=Sheets("Dispute").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
For i = 2 To lastRow
If Sheets("Sheet1").Cells(i, "A").Value Like "*Unlatching*" Then
Sheets("Sheet1").Cells(i, "A").Columns("A:H").Copy Destination:=Sheets("Unlatching").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
For i = 2 To lastRow
If Sheets("Sheet1").Cells(i, "A").Value Like "*Port*" Then
Sheets("Sheet1").Cells(i, "A").Columns("A:H").Copy Destination:=Sheets("Port In").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
For i = 2 To lastRow
If Sheets("Sheet1").Cells(i, "A").Value Like "*Age Verification*" Then
Sheets("Sheet1").Cells(i, "A").Columns("A:H").Copy Destination:=Sheets("Age Verification").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
For i = 2 To lastRow
If Sheets("Sheet1").Cells(i, "A").Value Like "*Direct Debit*" Then
Sheets("Sheet1").Cells(i, "A").Columns("A:H").Copy Destination:=Sheets("DD Date Change").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
For i = 2 To lastRow
If Sheets("Sheet1").Cells(i, "A").Value Like "*DISE to Pay*" Then
Sheets("Sheet1").Cells(i, "A").Columns("A:H").Copy Destination:=Sheets("DISE Migration").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i

lastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastRow
Sheets("Sheet1").Columns("I:I").Select
Selection.ClearContents
Sheets("Sheet1").Cells(i, "A").Columns("A:H").ClearContents
Next i
Range("A1").Select
' Show summary message
MsgBox "Finished" _
End Sub

 

[Kaper]

Please use code tags around code you paste in the post. See below how readability is improved.

The code after cleaning:

Sub Button1_Click()
Dim i As Long, lastRow As Long


'new variables
Dim j As Long, My_AH, My_SIM(), SIMcount As Long, My_DUP(), DUPcount
' and similar pairs for Dispute, Unlatching etc.




'only slight optimization - no selection used
lastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Application.DisplayAlerts = False
Application.CutCopyMode = False
Range("G2:G" & lastRow).TextToColumns Destination:=Range("G2"), DataType:=xlDelimited, _
  TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
  Semicolon:=False, Comma:=False, Space:=True, Other:=False


' rewritten part
My_AH = Range("A2:H" & lastRow).Value
ReDim My_SIM(1 To lastRow - 1, 1 To 8)
ReDim My_DUP(1 To lastRow - 1, 1 To 8)
' and so on for Dispute, Unlatching etc.




For i = 1 To lastRow - 1 'in table there is one row less
  If (My_AH(i, 1) Like "*SIM*") Or (My_AH(i, 1) Like "*SSN*") Or (My_AH(i, 1) Like "*Sim*") Then
    SIMcount = SIMcount + 1
    For j = 1 To 8
      My_SIM(SIMcount, j) = My_AH(i, j)
    Next j
  End If
  If My_AH(i, 1) Like "*Duplicate*" Then
    DUPcount = DUPcount + 1
    For j = 1 To 8
      My_DUP(DUPcount, j) = My_AH(i, j)
    Next j
  End If
  ' and so on for Dispute, Unlatching etc.
Next i
If SIMcount > 0 Then Sheets("SIM").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(SIMcount, 8).Value = My_SIM
If DUPcount > 0 Then Sheets("Duplicate Account").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(DUPcount, 8).Value = My_DUP
' and so on for Dispute, Unlatching etc.


' last part - it was without a reason in a loop,
' also recalculation of lastrow was not needed.
' and no point to clear first I then A:H
Sheets("Sheet1").Columns("A:I").ClearContents
MsgBox "Finished"
End Sub

 

[danny8890]

This is amazing!, so much quicker! thank you.

Only 1 issue I can see is it clears the whole Sheet1 now, I need row 1 not to be cleared?

 

[danny8890]

This is amazing!, so much quicker! thank you.

Only 1 issue I can see is it clears the whole Sheet1 now, I need row 1 not to be cleared?

Never mind just changed the code

 

[danny8890]

There is only 1 other problem I've spotted, when the data is being pasted into the sheets it is unwrapping the text?. Didn't do this before could you assist please?

 

[Kaper]

The code is not directly copying. It first reads all data values into array, then collects selected data in output arrays, and finally pastes output arrays values to respective sheets. So formatting cannot be preserved this way.

Assuming there is already some data in output sheets, probably easiest way to copy formatting is:

'...
 Next iIf SIMcount > 0 Then 
  with Sheets("SIM").Range("A" & Rows.Count).End(xlUp)
    .resize(1,8).copy  .Offset(1).Resize(SIMcount, 8)
    .Offset(1).Resize(SIMcount, 8).Value = My_SIM
  end with
end if
If DUPcount > 0 Then 
  with Sheets("Duplicate Account").Range("A" & Rows.Count).End(xlUp)
    .resize(1,8).copy  .Offset(1).Resize(DUPcount, 8)
.Offset(1).Resize(DUPcount, 8).Value = My_DUP
  end with
end if
' and so on for Dispute, Unlatching etc.
' ...