Make code more economical

[Mark C]

Hi,

I have written a program in VBA for Excel. My problem is that as the code
uses some array variables I have a problem with Excel crashing after 6 to 10
times around the loop. Is there anyone that could look over my code and give
a few pointers as to how I could make it more economical.

I have not posted the code but would e-mail the workbook if OK

Many Thanks Mark

 

[Frank Kabel]

Hi
post the relevant part of your code (e.g. the loop procedure)

 

[Mark C]

Hi Frank, Here is the code. Regards Mark


Public Sub Format_Sheet()
'###############################################################
'Program to transfer and format plannings
'10 Sept 04
'#######################################

Dim strDetailL(16) As String
Dim strDetailR() As String
Dim strDetailBR() As String
Dim strToolDetail() As String
Dim strStartPoint As String
Dim strStartPointDetail As String
ActiveSheet.Select

'Collect Left Detail data
Range("c2").Select
For counterl = 1 To 16 Step 1
strDetailL(counter1) = ActiveCell.Value
ActiveCell.Offset(1, 0).Activate
counter1 = counter1 + 1
Next

'Collect Right Detail Data
Range("F2").Select
ReDim strDetailR(0)
strDetailR(0) = ActiveCell.Value
ActiveCell.Offset(1, 0).Activate
Do While ActiveCell.Offset(0, -5).Value <> "5"
ReDim Preserve strDetailR(UBound(strDetailR) + 1)
strDetailR(UBound(strDetailR)) = ActiveCell.Value
ActiveCell.Offset(1, 0).Activate
Loop

strStartPoint = ActiveCell.Offset(0, -1).Address

'Collect Bottom Right Data
ReDim strDetailBR(0)
strDetailBR(0) = ActiveCell.Value
ActiveCell.Offset(1, 0).Activate
Do While ActiveCell.Offset(0, -5).Value <> "***"
ReDim Preserve strDetailBR(UBound(strDetailBR) + 1)
strDetailBR(UBound(strDetailBR)) = ActiveCell.Value
ActiveCell.Offset(1, 0).Activate
Loop

'collect tool data
Range(strStartPoint).Activate
ReDim strToolDetail(0)
strToolDetail(0) = ActiveCell.Value
ActiveCell.Offset(1, 0).Activate
Do While ActiveCell.Offset(0, -4).Value <> "***"
ReDim Preserve strToolDetail(UBound(strToolDetail) + 1)
strToolDetail(UBound(strToolDetail)) = ActiveCell.Value
ActiveCell.Offset(1, 0).Activate
Loop

'Place data in new sheet and format PNo and Desc
Sheets("sheet1").Select
Range("B1").Select
ActiveCell.Value = Replace(strDetailL(0), "Partno", "")
ActiveCell.Offset(0, 4).Value = Replace(strDetailL(1), "Descr..", "")
Range("B1:F1").Select
Selection.Font.Bold = True
Selection.Font.Size = "12"


'Remove PartNo and Qty from string
Dim PNo()
Dim Qty()
Dim ID()
ReDim PNo(UBound(strDetailR))
ReDim Qty(UBound(strDetailR))
ReDim ID(UBound(strDetailR))
For c = 1 To UBound(strDetailR) Step 2
ID(c) = Trim(Left(strDetailR(c), 3))
PNo(c) = Trim(Mid(strDetailR(c), 4, 12))
Qty(c) = Trim(Mid(strDetailR(c), 16, 26))

Next

'Remove Description from string
Dim Desc()
ReDim Desc(UBound(strDetailR))
For c = 2 To UBound(strDetailR) Step 2
Desc(c) = Trim(Mid(strDetailR(c), 7, 20))
Next

'###########################################################################
##
'Short odds fix
If UBound(strDetailR) < 20 Then

Range("A17").Select
strStartPointDetail = ActiveCell.Address
Selection.Font.Bold = True
Range(strStartPointDetail).Value = "ID"
ActiveCell.Offset(1, 0).Activate
For counter4 = 1 To UBound(strDetailR) Step 2
ActiveCell.Value = ID(counter4)
ActiveCell.Offset(1, 0).Activate
Next


'Full Parts List Part Number Left Block
Range(strStartPointDetail).Offset(0, 1).Select
Selection.Font.Bold = True
Range(strStartPointDetail).Offset(0, 1).Value = "Parts No"
ActiveCell.Offset(1, 0).Activate
For counter4 = 1 To UBound(strDetailR) Step 2
ActiveCell.Value = PNo(counter4)
ActiveCell.Offset(1, 0).Activate
Next

'Full Parts List Description Left Block
Range(strStartPointDetail).Offset(0, 2).Select
Selection.Font.Bold = True
Selection.Value = "Description"
ActiveCell.Offset(1, 0).Activate
For counter4 = 2 To UBound(strDetailR) Step 2

ActiveCell.Value = StrConv(Desc(counter4), vbProperCase)
ActiveCell.Offset(1, 0).Activate
Next

'Full Parts List Qty Left Block
Range(strStartPointDetail).Offset(0, 3).Select
Selection.Font.Bold = True
Selection.Value = "Qty"
ActiveCell.Offset(1, 0).Activate
For counter4 = 1 To UBound(strDetailR) Step 2
ActiveCell.Value = Replace(Qty(counter4), "ITEMS", "")
If InStr(1, ActiveCell.Value, "/") > 1 Then
ActiveCell.NumberFormat = "mm/y"
End If
ActiveCell.Offset(1, 0).Activate
Next


Else
'###########################################################################
##############
'Left Block

'Full Parts List ID Left Block
Range("A17").Select
strStartPointDetail = ActiveCell.Address
Selection.Font.Bold = True
Range(strStartPointDetail).Value = "ID"
ActiveCell.Offset(1, 0).Activate
For counter4 = 1 To Int(UBound(strDetailR) / 2) Step 2
ActiveCell.Value = ID(counter4)
ActiveCell.Offset(1, 0).Activate
Next

'Full Parts List Part Number Left Block
Range(strStartPointDetail).Offset(0, 1).Select
Selection.Font.Bold = True
Range(strStartPointDetail).Offset(0, 1).Value = "Parts No"
ActiveCell.Offset(1, 0).Activate
For counter4 = 1 To Int(UBound(strDetailR) / 2) Step 2
ActiveCell.Value = PNo(counter4)
ActiveCell.Offset(1, 0).Activate
Next

'Full Parts List Description Left Block
Range(strStartPointDetail).Offset(0, 2).Select
Selection.Font.Bold = True
Selection.Value = "Description"
ActiveCell.Offset(1, 0).Activate
For counter4 = 2 To Int(UBound(strDetailR) / 2) + 1 Step 2
ActiveCell.Value = StrConv(Desc(counter4), vbProperCase)
ActiveCell.Offset(1, 0).Activate
Next

'Full Parts List Qty Left Block
Range(strStartPointDetail).Offset(0, 3).Select
Selection.Font.Bold = True
Selection.Value = "Qty"
ActiveCell.Offset(1, 0).Activate
For counter4 = 1 To Int(UBound(strDetailR) / 2) Step 2
ActiveCell.Value = Replace(Qty(counter4), "ITEMS", "")
If InStr(1, ActiveCell.Value, "/") > 1 Then
ActiveCell.NumberFormat = "mm/y"
End If
ActiveCell.Offset(1, 0).Activate
Next

'###########################################################################
##############
'Right Block

If val(UBound(strDetailR) / 2 Mod 2) = 0 Then

Range(strStartPointDetail).Offset(0, 5).Select
Selection.Font.Bold = True
Selection.Value = "ID"
ActiveCell.Offset(1, 0).Activate
For counter4 = Int(UBound(strDetailR) / 2) + 1 To UBound(strDetailR) Step 2
ActiveCell.Value = ID(counter4)
ActiveCell.Offset(1, 0).Activate
Next

'Full Parts List Part Number Right Block
Range(strStartPointDetail).Offset(0, 6).Select
Selection.Font.Bold = True
Selection.Value = "Parts No"
ActiveCell.Offset(1, 0).Activate
For counter4 = Int(UBound(strDetailR) / 2) + 1 To UBound(strDetailR) Step 2
ActiveCell.Value = PNo(counter4)
ActiveCell.Offset(1, 0).Activate
Next


'Full Parts List Description Right Block
Range(strStartPointDetail).Offset(0, 7).Select
Selection.Font.Bold = True
Selection.Value = "Description"
ActiveCell.Offset(1, 0).Activate
For counter4 = Int(UBound(strDetailR) / 2) + 2 To UBound(strDetailR) Step 2
ActiveCell.Value = StrConv(Desc(counter4), vbProperCase)
ActiveCell.Offset(1, 0).Activate
Next


'Full Parts List Qty Right Block
Range(strStartPointDetail).Offset(0, 8).Select
Selection.Font.Bold = True
Selection.Value = "Qty"
ActiveCell.Offset(1, 0).Activate
For counter4 = Int(UBound(strDetailR) / 2) + 1 To UBound(strDetailR) Step 2
ActiveCell.Value = Replace(Qty(counter4), "ITEMS", "")
If InStr(1, ActiveCell.Value, "/") > 1 Then
ActiveCell.NumberFormat = "mm/y"
End If
ActiveCell.Offset(1, 0).Activate
Next

Else

Range(strStartPointDetail).Offset(0, 5).Select
Selection.Font.Bold = True
Selection.Value = "ID"
ActiveCell.Offset(1, 0).Activate
For counter4 = Int(UBound(strDetailR) / 2) + 2 To UBound(strDetailR) Step 2
ActiveCell.Value = ID(counter4)
ActiveCell.Offset(1, 0).Activate
Next


'Full Parts List Part Number Right Block
Range(strStartPointDetail).Offset(0, 6).Select
Selection.Font.Bold = True
Selection.Value = "Parts No"
ActiveCell.Offset(1, 0).Activate
For counter4 = Int(UBound(strDetailR) / 2) + 2 To UBound(strDetailR) Step 2
ActiveCell.Value = PNo(counter4)
ActiveCell.Offset(1, 0).Activate
Next


'Full Parts List Description Right Block
Range(strStartPointDetail).Offset(0, 7).Select
Selection.Font.Bold = True
Selection.Value = "Description"
ActiveCell.Offset(1, 0).Activate
For counter4 = Int(UBound(strDetailR) / 2) + 3 To UBound(strDetailR) Step 2
ActiveCell.Value = StrConv(Desc(counter4), vbProperCase)
ActiveCell.Offset(1, 0).Activate
Next


'Full Parts List Qty Right Block
Range(strStartPointDetail).Offset(0, 8).Select
Selection.Font.Bold = True
Selection.Value = "Qty"
ActiveCell.Offset(1, 0).Activate
For counter4 = Int(UBound(strDetailR) / 2) + 2 To UBound(strDetailR) Step 2
ActiveCell.Value = Replace(Qty(counter4), "ITEMS", "")
If InStr(1, ActiveCell.Value, "/") > 1 Then
ActiveCell.NumberFormat = "mm/y"
End If
ActiveCell.Offset(1, 0).Activate
Next


End If
End If

SI_MergedCells

'Special Instructions
Range("B3").Select
Selection.Font.Bold = True
Range("B3").Value = "Special Instructions"
ActiveCell.Offset(1, 0).Activate
For COUNTER3 = 1 To UBound(strDetailBR)
ActiveCell.Value = StrConv(strDetailBR(COUNTER3), vbProperCase)
ActiveCell.Offset(1, 0).Activate
Next

Range("A1").Select

Format_Borders

'Format cols and print area
Range("A1").Select
Columns("a:a").ColumnWidth = 5
Columns("B:B").ColumnWidth = 9
Columns("c:c").ColumnWidth = 20
Columns("d:d").ColumnWidth = 8
Columns("E:E").ColumnWidth = 2
Columns("F:F").ColumnWidth = 5
Columns("g:g").ColumnWidth = 9
Columns("h:h").ColumnWidth = 20
Columns("I:I").ColumnWidth = 8
ActiveSheet.PageSetup.PrintArea = "$A$1:$i$56"
Range("A1").Select
With ActiveSheet.PageSetup
.Orientation = xlPortrait
.Draft = False
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0.2)
.TopMargin = Application.InchesToPoints(0.3)
.FitToPagesTall = 1
.FitToPagesWide = 1
.LeftFooter = "&D"
.CenterHorizontally = True
End With


'Jig Detail

Range("B4949").Select
Selection.Merge
Range("B5050").Select
Selection.Merge
Range("B5151").Select
Selection.Merge
Range("B5252").Select
Selection.Merge
Range("B5353").Select
Selection.Merge
Range("B5454").Select
Selection.Merge
Range("B5050").Select


Range("b49").Select
Selection.Font.Bold = True
Range("b49").Value = "Jig Details"
ActiveCell.Offset(1, 0).Activate
For COUNTER2 = 0 To UBound(strToolDetail) / 2 Step 2
ActiveCell.Value = strToolDetail(COUNTER2) & " - " &
strToolDetail(COUNTER2 + 1)
ActiveCell.Offset(1, 0).Activate
Next

Range("B3:H14").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
End With


'########################################################################
'Mod 16/09/04 to add line and enter Container and Qty
'

Rows("2:3").Select
Selection.Insert Shift:=xlDown
Range("H2").Select
ActiveCell.FormulaR1C1 = "Container"
Range("H3").Select
ActiveCell.FormulaR1C1 = "Qty"
Range("H2:I3").Select
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With



Range("I2").Select
ActiveCell.FormulaR1C1 = _

"=IF(ISNA(VLOOKUP(TRIM(R1C2),'0166.DIF'!R4C1:R1000C4,4,FALSE)),0,VLOOKUP(TRI
M(R1C2),'0166.DIF'!R4C1:R1000C4,4,FALSE))"

Range("I3").Select
ActiveCell.FormulaR1C1 = _

"=IF(ISNA(VLOOKUP(TRIM(R1C2),'0166.DIF'!R4C1:R1000C4,3,FALSE)),0,VLOOKUP(TRI
M(R1C2),'0166.DIF'!R4C1:R1000C4,3,FALSE))"
Range("I4").Select



Range("A1").Select





End Sub

 

[Frank Kabel]

Hi Mark
first I asked for the relevant part So you may indicate where your
code does not work.
Some general points: You use Select + Activate + Activecell. You should
get rid of this (will slow down your code, etc.). e.g. the first
sttements could be written as follows:

Public Sub Format_Sheet()
'###############################################################
'Program to transfer and format plannings
'10 Sept 04
'#######################################

Dim strDetailL(16) As String
Dim strDetailR() As String
Dim strDetailBR() As String
Dim strToolDetail() As String
Dim strStartPoint As String
Dim strStartPointDetail As String
Dim counter As Integer


With ActiveSheet
'Collect Left Detail data
strDetailL = .Range("C2:C17").Value

'Collect Right Detail Data
ReDim strDetailR(0)
strDetailR(0) = .Range("F2").Value
counter = 3
Do While .Cells(counter, 1).Value <> "5"
ReDim Preserve strDetailR(UBound(strDetailR) + 1)
strDetailR(UBound(strDetailR)) = .Cells(counter, 1).Value
counter = counter + 1
Loop

strStartPoint = .Cells(counter, 5).Address
End With
.....




--
Regards
Frank Kabel
Frankfurt, Germany

news:[email protected]...

 

[Mark C]

Hi Frank,

Thanks for the quick response. The program does not error in any
particular place. The code runs through OK for about 8 to12 loops then I get
an error in Excel saying - " General Protection Fault in Module KRNL386". I
presumed it to be poor programming and was looking for some suggestions. I
think you may have answered my question with that. I will review the code
and see.

Many Thanks for you help Mark