Solved: auto copy and sort on change 2 columns

[mperrah]

I'm trying to auto update a list of tech names and ID numbers (2 columns)
when ever a new tech is added to a source sheet, I need to copy and past it to a techlist sheet and sort (name and ID) keeping the name and id linked

I found a code to paste 1 column and sort,
I modified the code to sort both columns,
I'm having trouble seeing how to update both columns (paste 2 columns for sorting).

Also the source sheet has a datavalidation list as the target,
I either need to make this dv copy all the way down the page for the code to work,
or find a way to make the code work without the dataval cell.
I'm not sure if the code can be altered so the dv is not necessary.
The source sheet gives you the option of clicking a drop down list to change the value in the source cell, I don't need this option.
I have a macro that pastes data to the source sheet and I will not change it after that.
The pasted data just needs to be scanned for new unique values and add the unique values to the archive list and sort it by tech ID.

This is the code on the source sheet (QCDetail):
[vba]Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim ws As Worksheet
Dim i As Integer
Dim rngDV As Range
Dim rng As Range
If Target.Count > 1 Then Exit Sub
Set ws = Worksheets("wqc")
If Target.Row > 1 Then

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo 0
If rngDV Is Nothing Then Exit Sub
If Intersect(Target, rngDV) Is Nothing Then Exit Sub
Set rng = ws.Range(Cells(1, Target.Column) & "List")
If Application.WorksheetFunction _
.CountIf(rng, Target.Value) Then
Exit Sub
Else
i = ws.Cells(Rows.Count, rng.Column).End(xlUp).Row + 1
ws.Cells(i, rng.Column).Value = Target.Value
Set rng = ws.Range(Cells(1, Target.Column) & "List")
End If
End If
End Sub[/vba]

here is the archive sheet (wqc) that sorts the 2 columns:
[vba]Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Range("techarray").Select
ActiveWorkbook.Worksheets("wqc").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("wqc").Sort.SortFields.Add _
Key:=Range("techid"), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("wqc").Sort
.SetRange Range("techarray")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
End Sub[/vba]

the techID range is named :
=OFFSET(wqc!$B$1,0,0,COUNTA(wqc!$B:$B),1)

the tech name range is named:
=OFFSET(wqc!$A$1,0,0,COUNTA(wqc!$A:$A),1)

the techname and id array is named:
=techarray

I've attached the file.
Thanks in advance
Mark

[mperrah]

I found this file that makes a userform extracting unique values and sorting.
I'm trying to get the additem to add to a cell range instead of the userform.
Here is the origional code slightly modified (works on the form)
[vba]Option Explicit
' This example is based on a tip by J.G. Hussey,
' published in "Visual Basic Programmer's Journal"
Sub RemoveDuplicates()
Dim AllCells As Range, Cell As Range, Cellb As Range
Dim AllCellsb As Range
Dim NoDupes As New Collection
Dim NoDupesb As New Collection
Dim i As Integer, j As Integer
Dim ib As Integer, jb As Integer
Dim Swap1, Swap2, Item
Dim Swap1b, Swap2b, Itemb

' The items are in a range named Countries
Set AllCells = Range("TechName")
Set AllCellsb = Range("TechID")

' The next statement ignores the error caused
' by attempting to add a duplicate key to the collection.
' The duplicate is not added - which is just what we want!
On Error Resume Next
For Each Cell In AllCells
NoDupes.Add Cell.Value, CStr(Cell.Value)
' Note: the 2nd argument (key) for the Add method must be a string
Next Cell

For Each Cellb In AllCellsb
NoDupesb.Add Cellb.Value, CStr(Cellb.Value)
' Note: the 2nd argument (key) for the Add method must be a string
Next Cellb
' Resume normal error handling
On Error GoTo 0
' Update the labels on UserForm1
With UserForm1
.Label1.Caption = "Total Techs: " & AllCells.Count
.Label2.Caption = "Unique Techs: " & NoDupes.Count
.Label3.Caption = "Total IDs: " & AllCellsb.Count
.Label4.Caption = "Unique IDs: " & NoDupesb.Count
End With

' Sort the collection (optional)
For i = 1 To NoDupes.Count - 1
For j = i + 1 To NoDupes.Count
If NoDupes(i) > NoDupes(j) Then
Swap1 = NoDupes(i)
Swap2 = NoDupes(j)
NoDupes.Add Swap1, before:=j
NoDupes.Add Swap2, before:=i
NoDupes.Remove i + 1
NoDupes.Remove j + 1
End If
Next j
Next i
For ib = 1 To NoDupesb.Count - 1
For jb = ib + 1 To NoDupesb.Count
If NoDupesb(ib) > NoDupesb(jb) Then
Swap1b = NoDupesb(ib)
Swap2b = NoDupesb(jb)
NoDupesb.Add Swap1b, before:=jb
NoDupesb.Add Swap2b, before:=ib
NoDupesb.Remove ib + 1
NoDupesb.Remove jb + 1
End If
Next jb
Next ib

' Add the sorted, non-duplicated items to a ListBox
For Each Item In NoDupes
UserForm1.ListBox1.AddItem Item
Next Item
For Each Itemb In NoDupesb
UserForm1.ListBox2.AddItem Itemb
Next Itemb
' Show the UserForm
UserForm1.Show
End Sub
[/vba]


This is what I have so far.
It stops at this line

    Range("B:B").Value = NoDupes

I think the entire collection could just be pasted to b1 and fill down,
Not sure if it needs a loop because the values are allready arranged and sorted, so the entire collection should be able to be just pasted.
I tried the range.value = collection idea, but no go...
Any Ideas?
[vba]Option Explicit
Sub RemoveDuplicates()
Dim AllCells As Range, Cell As Range, Cellb As Range
Dim AllCellsb As Range
Dim NoDupes As New Collection
Dim NoDupesb As New Collection
Dim i As Integer, j As Integer
Dim ib As Integer, jb As Integer
Dim Swap1, Swap2, Item
Dim Swap1b, Swap2b, Itemb
Dim wsDest As Worksheet


' The items are in a range named TechName and Techs
Set AllCells = Worksheets("QCDetail").Range("TechName") ' column A QCDetail
Set AllCellsb = Worksheets("QCDetail").Range("Techs") ' column B QCDetail Sort this
Set wsDest = Worksheets("WQC")

' The next statement ignores the error caused
' by attempting to add a duplicate key to the collection.
' The duplicate is not added - which is just what we want!
On Error Resume Next
For Each Cell In AllCells
NoDupes.Add Cell.Value, CStr(Cell.Value)
' Note: the 2nd argument (key) for the Add method must be a string
Next Cell

For Each Cellb In AllCellsb
NoDupesb.Add Cellb.Value, CStr(Cellb.Value)
' Note: the 2nd argument (key) for the Add method must be a string
Next Cellb
' Resume normal error handling
On Error GoTo 0
' Sort the collection (optional)
For i = 1 To NoDupes.Count - 1
For j = i + 1 To NoDupes.Count
If NoDupes(i) > NoDupes(j) Then
Swap1 = NoDupes(i)
Swap2 = NoDupes(j)
NoDupes.Add Swap1, before:=j
NoDupes.Add Swap2, before:=i
NoDupes.Remove i + 1
NoDupes.Remove j + 1
End If
Next j
Next i
For ib = 1 To NoDupesb.Count - 1
For jb = ib + 1 To NoDupesb.Count
If NoDupesb(ib) > NoDupesb(jb) Then
Swap1b = NoDupesb(ib)
Swap2b = NoDupesb(jb)
NoDupesb.Add Swap1b, before:=jb
NoDupesb.Add Swap2b, before:=ib
NoDupesb.Remove ib + 1
NoDupesb.Remove jb + 1
End If
Next jb
Next ib

' Add the sorted, non-duplicated items to a ListBox

With Sheets("WQC")
.Range("B1:B" & Rows.Count).ClearContents
.Range("C1:C" & Rows.Count).ClearContents
End With

For Each Item In NoDupes ' Tech Name
' UserForm1.ListBox1.AddItem Item
Range("B:B").Value = NoDupes
Next Item

For Each Itemb In NoDupesb ' Tech ID
' UserForm1.ListBox2.AddItem Itemb
Range("C:C").Value = NoDupesb
Next Itemb
End Sub[/vba]

[Charlize]

Instead of the for each thing, try a loop from 1 to the number of items in NoDupes. Something like this (not tested).[VBA]For i = 1 To NoDupes.Count
'or NoDupes(i-1) if you start with zero in the array
Range("B" & i).Value = NoDupes(i)
Next i[/VBA]

[mperrah]

Solved this from contextures. Recorded a Macro to copy values from a range of formulas, then sort.

[mperrah]

Thanks

[mperrah]

Sorry Charlize,
I posted while you posted.
I'll test yours because mine is very slow...
Thanks.
Good to see your input always!
Mark

[mperrah]

Previous works in 2007 only

This one is 2000/2003 friendly

The macro recorder used a srtfield vlaue not in previous versions even though I was in compatibility mode... Go figure.

Hope this helps someone.

Mark