Hi all,
Look, no attachments!
If you want version 5, you can either e-mail me directly at:

[EMAIL PROTECTED]

Or, if you know your way around the VBA editor, you can simply replace all
the code in the module called 'BOM_sorter' with the listing below.

Regards

David Watling









Public Const top_column = 1
Public Const top_row = 2
Public Const qty_text = "Qty"
Public split_array() As String
Public Qty As Integer
Sub BOM_sort_with_format()
Call BOM_sort(True)
End Sub
Sub BOM_sort_without_format()
Call BOM_sort(False)
End Sub
Sub BOM_sort(with_format As Boolean)
Dim index_cells As Variant
i = 0

Application.ScreenUpdating = False
' insert 'Qty' column
If Cells(top_row - 1, top_column + 4) <> qty_text Then
' insert column
Columns(top_column + 4).Insert Shift:=xlToRight
Cells(top_row - 1, top_column + 4) = qty_text
End If

Do While (Cells(i + top_row, top_column) <> Empty) Or (Cells(i + top_row,
top_column + 1) <> Empty)
index_cells = Cells(i + top_row, top_column) & Cells(i + top_row,
top_column + 2)
Cells(i + top_row, top_column + 4) = 1
j = i + 1
Do While (Cells(j + top_row, top_column) <> Empty) Or (Cells(j + top_row,
top_column + 1) <> Empty)
If Cells(j + top_row, top_column) & Cells(j + top_row, top_column + 2) =
index_cells Then
If Cells(j + top_row, top_column + 1) <> Empty Then
' increment Qty column
Cells(i + top_row, top_column + 4) = Cells(i + top_row, top_column + 4) + 1
' append to upper row
If Cells(i + top_row, top_column + 1) = Empty Then
Cells(i + top_row, top_column + 1) = Cells(j + top_row, top_column + 1)
Else
Cells(i + top_row, top_column + 1) = Cells(i + top_row, top_column + 1) &
"," & Cells(j + top_row, top_column + 1)
End If
End If
' delete row
Rows(j + top_row).Delete
j = j - 1
End If
j = j + 1
Loop
i = i + 1
Loop

If with_format Then
i = 0
Do While (Cells(i + top_row, top_column) <> Empty) Or (Cells(i + top_row,
top_column + 1) <> Empty)
' format designators
Cells(i + top_row, top_column + 1) = sort_designators(Cells(i + top_row,
top_column + 1))
' fill in Qty column
Cells(i + top_row, top_column + 4) = Qty
i = i + 1
Loop
' data sort by part type & footprint
Range(Rows(top_row), Rows(top_row + i)).Sort _
Key1:=Columns(top_column + 1), _
Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
End If

Columns(top_column + 1).EntireColumn.AutoFit
Columns(top_column + 4).EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Function sort_designators(string_l)
Dim text_array() As String
Dim no_array() As String
Dim designators_array() As String
Dim types_array() As String
Dim types_flag As Boolean

' split up the string
split_array = Split(string_l, ",")
ReDim text_array(UBound(split_array))
ReDim no_array(UBound(split_array))
ReDim types_array(0)
Qty = UBound(split_array) + 1

n_types = 0
' remove spaces & split into text & numbers
For k = 0 To UBound(split_array)
split_array(k) = Replace(split_array(k), " ", "")
For num_len = 1 To Len(split_array(k))
charac_l = Asc(Mid$(split_array(k), num_len, 1))
If charac_l >= 48 And charac_l <= 57 Then Exit For
Next
num_len = num_len - 1
text_array(k) = Left$(split_array(k), num_len)
If text_array(k) <> "" Then
last_type = text_array(k)
Else
text_array(k) = last_type
End If
no_array(k) = Right$(split_array(k), Len(split_array(k)) - num_len)
types_flag = False
' count types
For l = 0 To UBound(types_array)
If text_array(k) = types_array(l) Then
types_flag = True
Exit For
End If
Next
If types_flag = False Then
ReDim Preserve types_array(UBound(types_array) + 1)
types_array(l - 1) = text_array(k)
End If
Next
ReDim Preserve types_array(UBound(types_array) - 1)
ReDim designators_array(UBound(types_array))

' re-order numbers & text (bubble sort)
For k = 0 To UBound(split_array)
For l = 0 To UBound(split_array) - 1
If Val(no_array(l)) > Val(no_array(l + 1)) Then
temp_text = no_array(l)
no_array(l) = no_array(l + 1)
no_array(l + 1) = temp_text
temp_text = text_array(l)
text_array(l) = text_array(l + 1)
text_array(l + 1) = temp_text
End If
Next
Next

' sort numbers to types
For k = 0 To UBound(types_array)
designators_array(k) = types_array(k)
For l = 0 To UBound(no_array)
If text_array(l) = types_array(k) Then
designators_array(k) = designators_array(k) & no_array(l) & ","
End If
Next
designators_array(k) = Left$(designators_array(k),
Len(designators_array(k)) - 1)
Next

' Join types
sort_designators = Join(designators_array, "; ")

End Function












* * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* To post a message: mailto:[EMAIL PROTECTED]
*
* To leave this list visit:
* http://www.techservinc.com/protelusers/leave.html
*
* Contact the list manager:
* mailto:[EMAIL PROTECTED]
*
* Forum Guidelines Rules:
* http://www.techservinc.com/protelusers/forumrules.html
*
* Browse or Search previous postings:
* http://www.mail-archive.com/[EMAIL PROTECTED]
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

Reply via email to