125ml
04-20-2017, 06:23 AM
Hello!
I am currently working on a VBA code is incorporated in an Excel extraction from our back office system.
The code basically takes the Excel data, sorts, merges cells, add subtitles and frames and most importantly incorporates image files from the server corresponding to the references in the file.
So far so good, the code generally works like a charm and the output is exactly what I need.
That said, from a certain number of data sets the file stops processing and Excel freezes. I have searched if this is due to a timeout or something else, but without any luck so far...
The datasets I am trying to extract are not huge either, the maximum I have tried is 1400 lines of data. It freezes from around 500 lines upwards.
Any input would be appreciated as it would be important for me to have this working with larger data sets.
Thanks in advance & please don't hesitate to let me know if you need any additional information.
Chees,
Reno
Here is the code I have so far:
Sub Colombus_Start()
'
' Colombus_Start Macro
'
Dim columnBrand As String: columnBrand = "A"
Dim columnGroup As String: columnGroup = "B"
Dim columnReference1 As String: columnReference1 = "C"
Dim columnReference2 As String: columnReference2 = "D"
Dim columnProduct As String: columnProduct = "E"
Dim columnImage As String: columnImage = "F"
Dim columnRangeReference1 As String: columnRangeReference1 = "C:C"
Dim counterRow As Long
Dim counterReference As Long
Dim strReference As String
Dim strImage As String
Dim intLastRow As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
intLastRow = Range("C" & Rows.Count).End(xlUp).Row
'Sort by Reference & Custom Sort by Size
With ActiveWorkbook.ActiveSheet.Sort
With .SortFields
.Clear
'Sort by Reference
.Add Key:=Range("C3:C" & intLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'Sort by Colour
.Add Key:=Range("G3:G" & intLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'Sort by Custom Range > Sizes
.Add Key:=Range("J3:J" & intLastRow), CustomOrder:="TU, SS, XS, S, M, L, EL, XL"
End With
.SetRange Range("A3:V" & intLastRow)
.Apply
End With
'Inserts SubTotals
Range("A3:V" & intLastRow).Select
Selection.Subtotal GroupBy:=3, Function:=xlSum, _
TotalList:=Array(14, 15, 16, 17, 18, 19, 20, 21, 22)
'Loop to change row height according to the number of rows per reference. This assures that the image will fit.
For counterRow = Cells(Rows.Count, columnReference1).End(xlUp).Row To 1 Step -1
strReference = Cells(counterRow, columnReference1)
counterReference = Application.WorksheetFunction.CountIf(Range(columnRangeReference1), strReference)
If Left(Cells(counterRow, columnReference1), 5) = "Total" Then
Rows(counterRow).RowHeight = 23
With Range(Cells(counterRow, "A"), Cells(counterRow, "V")).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Range(Cells(counterRow, "A"), Cells(counterRow, "V")).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Range(Cells(counterRow, "A"), Cells(counterRow, "V")).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Range(Cells(counterRow, "A"), Cells(counterRow, "V")).Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
Range(Cells(counterRow, "A"), Cells(counterRow, "K")).Merge
Range(Cells(counterRow, "A"), Cells(counterRow, "K")).VerticalAlignment = xlCenter
ElseIf Left(Cells(counterRow, columnReference1), 5) = "REF 1" Then
Rows(counterRow).RowHeight = 48
ElseIf counterReference = 1 Then
Rows(counterRow).RowHeight = 90
ElseIf counterReference = 2 Then
Rows(counterRow).RowHeight = 45
ElseIf counterReference = 3 Then
Rows(counterRow).RowHeight = 30
ElseIf counterReference = 4 Then
Rows(counterRow).RowHeight = 23
ElseIf counterReference = 5 Then
Rows(counterRow).RowHeight = 18
ElseIf counterReference = 6 Then
Rows(counterRow).RowHeight = 15
End If
Next counterRow
'Deletes redundant images & merges cells with identical values
For counterRow = Cells(Rows.Count, columnReference1).End(xlUp).Row To 1 Step -1
If Cells(counterRow, columnReference1) = Cells(counterRow + 1, columnReference1) Then
On Error Resume Next
Range(Cells(counterRow, columnBrand), Cells(counterRow + 1, columnBrand)).Merge
Range(Cells(counterRow, columnGroup), Cells(counterRow + 1, columnGroup)).Merge
Range(Cells(counterRow, columnReference1), Cells(counterRow + 1, columnReference1)).Merge
Range(Cells(counterRow, columnReference2), Cells(counterRow + 1, columnReference2)).Merge
Range(Cells(counterRow, columnProduct), Cells(counterRow + 1, columnProduct)).Merge
Range(Cells(counterRow, columnImage), Cells(counterRow + 1, columnImage)).Merge
End If
Next counterRow
'Gets image URL, finds image on server and inserts in in the active cell
For counterRow = Cells(Rows.Count, columnImage).End(xlUp).Row To 1 Step -1
On Error Resume Next
strImage = Cells(counterRow, columnImage).Value
Cells(counterRow, columnImage).Activate
Selection = ActiveSheet.Shapes.AddPicture(strImage, False, True, ActiveCell.Left + 4, ActiveCell.Top + 4, 86, 70)
Next counterRow
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveWorkbook.Save
End Sub
I am currently working on a VBA code is incorporated in an Excel extraction from our back office system.
The code basically takes the Excel data, sorts, merges cells, add subtitles and frames and most importantly incorporates image files from the server corresponding to the references in the file.
So far so good, the code generally works like a charm and the output is exactly what I need.
That said, from a certain number of data sets the file stops processing and Excel freezes. I have searched if this is due to a timeout or something else, but without any luck so far...
The datasets I am trying to extract are not huge either, the maximum I have tried is 1400 lines of data. It freezes from around 500 lines upwards.
Any input would be appreciated as it would be important for me to have this working with larger data sets.
Thanks in advance & please don't hesitate to let me know if you need any additional information.
Chees,
Reno
Here is the code I have so far:
Sub Colombus_Start()
'
' Colombus_Start Macro
'
Dim columnBrand As String: columnBrand = "A"
Dim columnGroup As String: columnGroup = "B"
Dim columnReference1 As String: columnReference1 = "C"
Dim columnReference2 As String: columnReference2 = "D"
Dim columnProduct As String: columnProduct = "E"
Dim columnImage As String: columnImage = "F"
Dim columnRangeReference1 As String: columnRangeReference1 = "C:C"
Dim counterRow As Long
Dim counterReference As Long
Dim strReference As String
Dim strImage As String
Dim intLastRow As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
intLastRow = Range("C" & Rows.Count).End(xlUp).Row
'Sort by Reference & Custom Sort by Size
With ActiveWorkbook.ActiveSheet.Sort
With .SortFields
.Clear
'Sort by Reference
.Add Key:=Range("C3:C" & intLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'Sort by Colour
.Add Key:=Range("G3:G" & intLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'Sort by Custom Range > Sizes
.Add Key:=Range("J3:J" & intLastRow), CustomOrder:="TU, SS, XS, S, M, L, EL, XL"
End With
.SetRange Range("A3:V" & intLastRow)
.Apply
End With
'Inserts SubTotals
Range("A3:V" & intLastRow).Select
Selection.Subtotal GroupBy:=3, Function:=xlSum, _
TotalList:=Array(14, 15, 16, 17, 18, 19, 20, 21, 22)
'Loop to change row height according to the number of rows per reference. This assures that the image will fit.
For counterRow = Cells(Rows.Count, columnReference1).End(xlUp).Row To 1 Step -1
strReference = Cells(counterRow, columnReference1)
counterReference = Application.WorksheetFunction.CountIf(Range(columnRangeReference1), strReference)
If Left(Cells(counterRow, columnReference1), 5) = "Total" Then
Rows(counterRow).RowHeight = 23
With Range(Cells(counterRow, "A"), Cells(counterRow, "V")).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Range(Cells(counterRow, "A"), Cells(counterRow, "V")).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Range(Cells(counterRow, "A"), Cells(counterRow, "V")).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Range(Cells(counterRow, "A"), Cells(counterRow, "V")).Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
Range(Cells(counterRow, "A"), Cells(counterRow, "K")).Merge
Range(Cells(counterRow, "A"), Cells(counterRow, "K")).VerticalAlignment = xlCenter
ElseIf Left(Cells(counterRow, columnReference1), 5) = "REF 1" Then
Rows(counterRow).RowHeight = 48
ElseIf counterReference = 1 Then
Rows(counterRow).RowHeight = 90
ElseIf counterReference = 2 Then
Rows(counterRow).RowHeight = 45
ElseIf counterReference = 3 Then
Rows(counterRow).RowHeight = 30
ElseIf counterReference = 4 Then
Rows(counterRow).RowHeight = 23
ElseIf counterReference = 5 Then
Rows(counterRow).RowHeight = 18
ElseIf counterReference = 6 Then
Rows(counterRow).RowHeight = 15
End If
Next counterRow
'Deletes redundant images & merges cells with identical values
For counterRow = Cells(Rows.Count, columnReference1).End(xlUp).Row To 1 Step -1
If Cells(counterRow, columnReference1) = Cells(counterRow + 1, columnReference1) Then
On Error Resume Next
Range(Cells(counterRow, columnBrand), Cells(counterRow + 1, columnBrand)).Merge
Range(Cells(counterRow, columnGroup), Cells(counterRow + 1, columnGroup)).Merge
Range(Cells(counterRow, columnReference1), Cells(counterRow + 1, columnReference1)).Merge
Range(Cells(counterRow, columnReference2), Cells(counterRow + 1, columnReference2)).Merge
Range(Cells(counterRow, columnProduct), Cells(counterRow + 1, columnProduct)).Merge
Range(Cells(counterRow, columnImage), Cells(counterRow + 1, columnImage)).Merge
End If
Next counterRow
'Gets image URL, finds image on server and inserts in in the active cell
For counterRow = Cells(Rows.Count, columnImage).End(xlUp).Row To 1 Step -1
On Error Resume Next
strImage = Cells(counterRow, columnImage).Value
Cells(counterRow, columnImage).Activate
Selection = ActiveSheet.Shapes.AddPicture(strImage, False, True, ActiveCell.Left + 4, ActiveCell.Top + 4, 86, 70)
Next counterRow
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveWorkbook.Save
End Sub