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] * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
