Macro for Sorting Data

[Sunrise]

Every month I have to do a large data sorting exercise and I currently do it all by hand so I want to learn how to do it using macros. I have 3 columns of data: A, B and C. How can I search down the entire column A, row by row, looking for the equivalent value and/or string in column B? If column B does in fact have an equivalent value and/or string then move both the column B and column C cell values up to the same row as column A.

Example: Using the value in cell A1 (e.g. value is 25000), search column B for the value 25,000. If the value is found in column B (e.g. say on row 200) then move (by Cut & Paste) both the column B and the column C cells (both also on row 200) up to cells B1 and C1 (i.e. so they are level with the A1 value). If 2 occurrences of the 25,000 value are found (note: there can be more) in column B then for each additional value found add a blank row before Cutting & Pasting the additional value into cells B2/C2, or B3/C3 etc. etc. Once done, repeat the same process for the next value in the original column A.

That’s essentially the process I now go through manually for worksheet data that is 800-900 rows long. It takes me quite a few hours to finish it and I would like to have a macro that can do it all much more quickly. Can anyone help me? I'm sure it is fairly complex answer so if you cannot I thank you in advance anyway.

[smozgur]

Hi Sunrise,

This code does what you need.
Assume first row is caption row (no data)
and if there is not corresponding value for any A column value then that row would be blank.

Hope this works for you.

'///CODE START///
Sub JustDoIt()
Dim i As Integer, j As Integer, k As Integer
Dim p As Integer, L As Integer
Dim A(), BC()
Range("A1").Select
Selection.End(xlDown).Select
L = Selection.Row - 1
ReDim A(L, 2)
i = 2
Do
p = p + 1
A(p, 1) = Cells(i, 1)
j = -1
For k = 2 To L
If Cells(i, 1) = Cells(k, 2) Then
j = j + 1
End If
Next k
A(p, 2) = j + 1
k = 1
For k = 1 To j
Rows(i + k & ":" & i + k).Select
Selection.Insert Shift:=xlDown
Next k
L = L + k
i = i + k
Loop Until Cells(i, 1) = ""
ReDim BC(i - 1, 2)
L = i - 1
For i = 1 To L - 1
BC(i, 1) = Cells(i + 1, 2)
BC(i, 2) = Cells(i + 1, 3)
Next i
k = 2
For i = 1 To UBound(A, 1)
If A(i, 2) = 0 Then
Cells(k, 2) = ""
Cells(k, 3) = ""
k = k + 1
Else
For j = 1 To L - 1
If A(i, 1) = BC(j, 1) Then
Cells(k, 2) = BC(j, 1)
Cells(k, 3) = BC(j, 2)
k = k + 1
End If
Next j
End If
Next i
End Sub
'///CODE END///

Regards





_________________
Oz ~ TheWordExpert

[ This Message was edited by: smozgur on 2002-04-21 06:44 ]

[Sunrise]

Thank you very much for your help. There seems to be some overwriting of the test data that I just tried it with. I think I will try and work on the code you provided so I can try and learn something about macros and how VBA works.

I appreciate your help - it is invaluable. I know you put in a good deal of time to write this for me and perhaps I can walk through and tweak it further to make it work perfectly for me. If I cannot then rest assured I will post something about my troubles.

[smozgur]

It's my pleasure Sunrise.

If you have trouble about it please let me know via email.

Edited:
I am completely sure that it was working correct with 99 data cell. Can you provide an excel file to test for me?


_________________
Oz ~ TheWordExpert

[ This Message was edited by: smozgur on 2002-04-21 13:24 ]