got error 1004 when executing this code
Hi everyone, I haven't programmed in VBA for ages, was reviewing to no avail some code I'm not the user of, that raises an error message 1004 (don't have the details handy at the moment) at the following line:
If levelcell <= 15 Then levelcell.InsertIndent levelcell
don't see a levelcell object having being created anywhere, don't know whether there's a built-in function with a similar name in Excel to create indentations?
[vba]
Sub IndentBAAM()
Dim LastCell As Variant
Dim intLoop As Integer, intRow As Integer, intPosition As Integer
Dim intX As Integer, intY As Integer
Dim strRange As String, strPart As String
Dim BMCPFileName As String
Dim GroupRange As Variant
'Constants give headers Names
Const conLevel As Integer = 1
Const conPrefix As Integer = 2
Const conDrwg As Integer = 3
Const conSuffix As Integer = 4
Const conQty As Integer = 5
Const conQtyCum As Integer = 6
Const conUM As Integer = 7
Const conDesc As Integer = 8
Const conItype As Integer = 9
Const conHorz As Integer = 10
Const conMRP As Integer = 11
Const conStartDate As Integer = 12
Const conStopDate As Integer = 13
Const conRev As Integer = 14
Const conLeadTm As Integer = 15
Const conLeadTimeCum As Integer = 16
Const conMRPOrder As Integer = 17
Const conSeqNo As Integer = 18
Const conWhat As Integer = 19
Const conMRPOH As Integer = 20
Const conLbr As Integer = 21
Const conMatl As Integer = 22
Const conSetup As Integer = 23
Const conExtrn As Integer = 24
Const conMicsMatl As Integer = 25
Const conBlank As Integer = 26
BMCPFileName = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If BMCPFileName = "False" Then
MsgBox "Application Cancelled... ", vbOKOnly, "Cancel"
Exit Sub
End If
Application.ScreenUpdating = False
Workbooks.OpenText Filename:=BMCPFileName, Origin:= _
xlWindows, StartRow:=6, DataType:=xlDelimited, _
Tab:=False, Semicolon:=False, Comma:=False, Other:=True, OtherChar:="~", FieldInfo:= _
Array(Array(conLevel, 1), Array(conPrefix, 2), Array(conDrwg, 2), Array(conSuffix, 9), _
Array(conQty, 1), Array(conQtyCum, 9), Array(conUM, 2), Array(conDesc, 2), _
Array(conItype, 2), Array(conHorz, 2), Array(conMRP, 2), Array(conStartDate, 9), _
Array(conStopDate, 9), Array(conRev, 2), Array(conLeadTm, 1), Array(conLeadTimeCum, 1), _
Array(conMRPOrder, 9), Array(conSeqNo, 9), Array(conWhat, 9), Array(conMRPOH, 9), _
Array(conLbr, 9), Array(conMatl, 9), Array(conSetup, 9), Array(conExtrn, 9), _
Array(conMicsMatl, 9), Array(conBlank, 9))
'Perform initial Formatting
'************************************************************************** ***********'
Range("A:L").Font.Size = 14
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1") = "Level"
Range("B1") = "Pin"
Range("C1") = "Drawing#"
Range("D1") = "Qty"
Range("E1") = "UM"
Range("F1") = "Description"
Range("G1") = "T"
Range("H1") = "H"
Range("I1") = "Planner"
Range("J1") = "Revision"
Range("K1") = "LeadTime"
Range("L1") = "CumLeadTime"
Cells.EntireColumn.AutoFit
Range("A1:L1").Select
Selection.Font.Bold = True
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
Columns("F:F").Select
Selection.Cut
Columns("D:D").Select
Selection.Insert Shift:=xlToRight
Columns("B:B").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
Columns("E:L").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
' Indent Each Level
'No indent level zero, so use this for the parent
Range("A2").HorizontalAlignment = xlLeft
'Indent the rest of the rows by their value
For Each levelcell In ActiveSheet.Range("A3:A" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row)
If levelcell <= 15 Then levelcell.InsertIndent levelcell
Next levelcell
' Fit everything to one window
ActiveWindow.View = xlPageBreakPreview
Cells.Select
Cells.EntireColumn.AutoFit
ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
ActiveWindow.View = xlNormalView
Range("A1").Select
' Repeat header on each sheet
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
End With
'Trim the fields to eliminate any extra spaces
For intLoop = 1 To 3
If intLoop = 1 Then strRange = "C1:C" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row
If intLoop = 2 Then strRange = "D1:D" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row
If intLoop = 3 Then strRange = "I1:I" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row
For Each TextCell In ActiveSheet.Range(strRange)
TextCell.Value = Trim(TextCell)
Next TextCell
Next intLoop
'Name Sheet the Top Level Drawing
strPart = Cells(2, 3)
'Make sure sheet name doesn't contain illegal Characters (Rev 3)
KillColon:
intPosition = InStr(strPart, ":")
If intPosition > 0 Then
strPart = Left(strPart, intPosition - 1) & Right(strPart, Len(strPart) - intPosition)
GoTo KillColon
End If
KillFSlash:
intPosition = InStr(strPart, "\")
If intPosition > 0 Then
strPart = Left(strPart, intPosition - 1) & Right(strPart, Len(strPart) - intPosition)
GoTo KillFSlash
End If
KillBSlash:
intPosition = InStr(strPart, "/")
If intPosition > 0 Then
strPart = Left(strPart, intPosition - 1) & Right(strPart, Len(strPart) - intPosition)
GoTo KillBSlash
End If
KillQuestMark:
intPosition = InStr(strPart, "?")
If intPosition > 0 Then
strPart = Left(strPart, intPosition - 1) & Right(strPart, Len(strPart) - intPosition)
GoTo KillQuestMark
End If
KillAst:
intPosition = InStr(strPart, "*")
If intPosition > 0 Then
strPart = Left(strPart, intPosition - 1) & Right(strPart, Len(strPart) - intPosition)
GoTo KillAst
End If
KillLBracket:
intPosition = InStr(strPart, "[")
If intPosition > 0 Then
strPart = Left(strPart, intPosition - 1) & Right(strPart, Len(strPart) - intPosition)
GoTo KillLBracket
End If
KillRBracket:
intPosition = InStr(strPart, "]")
If intPosition > 0 Then
strPart = Left(strPart, intPosition - 1) & Right(strPart, Len(strPart) - intPosition)
GoTo KillRBracket
End If
' Rename Sheet to Part Name
ActiveSheet.Name = strPart
' Add in document DART Prints
' Add a new sheet called Dart and copy of Drawing Numbers
Sheets.Add After:=Worksheets(Worksheets.Count)
Sheets("Sheet1").Name = "DART"
Sheets(strPart).Select
Columns("C:C").Copy
Sheets("DART").Select
Columns("A:A").Select
ActiveSheet.Paste
'for each cell get the drawing number
'if like "***L*" the kit so skip, If N* then bolt so truncate, else Left(8)
For intX = 2 To ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
If Cells(intX, 1) Like "***L*" Then
Cells(intX, 1) = ""
ElseIf Cells(intX, 1) Like "N*" Then
For intY = Len(Cells(intX, 1)) To 1 Step -1
If Mid(Cells(intX, 1), intY, 1) = "P" Then
Cells(intX, 1) = Left(Cells(intX, 1), intY - 1)
Exit For
End If
Next intY
Else
Cells(intX, 1) = Left(Cells(intX, 1), 8)
End If
Next intX
'Now sort out only distinct prints and delete the rest
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns("B:B"), Unique:=True
Columns("A:A").Delete
Columns("A:A").Select
Selection.Sort Key1:=Range("A1"), Header:=xlYes, Orientation:=xlTopToBottom
Columns("A:A").EntireColumn.AutoFit
If Cells(2, 1) = "" Then Cells(2, 1).Delete
Range("A1").Select
'Flip back to the BAAM
Sheets(strPart).Select
'************************************************************************** ***********'
'Determine Highest Outline Level
myHighLevel = 0
For Each levelcell In ActiveSheet.Range("A2:A" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row)
If levelcell > myHighLevel Then
myHighLevel = levelcell
End If
Next levelcell
'Set counters
counter = 0
myStartSize = 14
myStartColor = 3
'Change Font Styles
Do While counter <= myHighLevel
For Each levelcell In ActiveSheet.Range("A2:A" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row)
If levelcell = counter Then
levelcell.EntireRow.Font.ColorIndex = myStartColor
levelcell.EntireRow.Font.Size = myStartSize
End If
Next levelcell
counter = counter + 1
myStartColor = myStartColor + 1
If myStartSize > 7 Then
myStartSize = myStartSize - 1
Else: myStartSize = 7
End If
'Skip The Font Color Yellow, Hard to see
If myStartColor = 6 Then myStartColor = 7
If myStartColor = 19 Then myStartColor = 20
Loop
'Choose outline settings to use
With ActiveSheet.Outline
.AutomaticStyles = False
.SummaryRow = xlAbove
.SummaryColumn = xlRight
End With
'Reset Counters
counter = 1
mylevel = 1
'Sort and Set Outline levels
Do While counter <= myHighLevel
For Each levelcell In ActiveSheet.Range("A2:A" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row)
If levelcell = counter Then
levelcell.EntireRow.OutlineLevel = mylevel + 1
End If
Next levelcell
mylevel = mylevel + 1
counter = counter + 1
'Stop outline from passing Maximum level of 8
If mylevel = 8 Then mylevel = 7
Loop
Application.ScreenUpdating = True
'************************************************************************** ***********'
' End the program by saving the file
BMCPFileName = Application.GetSaveAsFilename(strPart, "Microsoft Excel Workbooks (*.xls), *.xls")
If BMCPFileName <> "False" Then
ActiveWorkbook.SaveAs Filename:= _
BMCPFileName, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
End If
'************************************************************************** *************'
End Sub
[/vba]
input txt file starts like this:
===============================================
From: sender@email.com
Sent: Wednesday, April 1, 2009 2:39 PM
To: recipient@mail.com
Subject: BMCP
00~ ~ML-9A1WFA78-2 ~ ~0000.00000~000000.00000~EA~TERMAL ~9~6~TM5M00 ~090415~000000~N/A~00000~00000~Y~000001~ ~00000000000~000000000000~000000000000~000000000000~000000000000~N~
===============================================
... any ideas? thanks!
