Macro Help

[Stanley Braverman]

I have column C and column D that contains data. I need macro that will IF
THEN with a loop till done;

1st condition. If C1 = D1 then do nothing(but look at next cells C2 and D2
etc. Etc.
2nd condition. If C1 < D1 then move cells in column C down.
(one cell at a time until condition one meet again and continue loop)
3rd condition. If C1 > D1 then move cells in column D down.
(one cell at a time until condition one meet again and continue loop)

Perhaps instead of a loop maybe an input for how many rows to do

By doing this cells that are being moved will leave a bank cell in it's
place and that is what is wanted.
Example:
PS1495-15 PS1495-15
PS1495-16 PS1495-16
PS1495-17
PS1495-18 PS1495-18
PS1495-19 PS1495-19

PSJT304-16 PSJT304-16
PSJT304-17 PSJT304-17
PSJT304-18 PSJT304-18
PSJT305-15
PSJT314-01 PSJT314-01
PSJT314-02 PSJT314-02


Thanks

 

[Joel]

I think this is easier than your method. I created an auxilary column with
the unique values. Then simply did a look up to find which items existed and
which didn't.


Sub matchrows()
'create new column C with unique values sorted
'create new column C, copy old c (now D) to c
Columns("C:C").Insert
Columns("D").Copy Destination:=Columns("C:C")

EndC = Range("C" & Rows.Count).End(xlUp).Row
EndE = Range("E" & Rows.Count).End(xlUp).Row
Range("E1:E" & EndE).Copy Destination:=Range("C" & (EndC + 1))

'insert new column to put unique values
Columns("C:C").Insert
'remove duplicates
EndD = Range("D" & Rows.Count).End(xlUp).Row
Range("D1" & EndD).AdvancedFilter _
Action:=xlFilterCopy, _
Unique:=True, _
CopyToRange:=Range("C1")
'delete original data
Columns("D").Delete

'sort column descending sending blank cells to end
EndC = Range("C" & Rows.Count).End(xlUp).Row
Range("C1:C" & EndC).Sort _
key1:=Range("C1"), _
Order1:=xlDescending, _
header:=xlNo

'sort back into correct order
EndC = Range("C" & Rows.Count).End(xlUp).Row
Range("C1:C" & EndC).Sort _
key1:=Range("C1"), _
Order1:=xlAscending, _
header:=xlNo

'create new rows D & E and move items to F to G matching unique items
Columns("D").Insert
Columns("D").Insert

'lookup items in E using column C and move to D
Range("D1").Formula = "=IF(IsNA(Match($C1,F$1:F$" & EndC & ",0)),"""",$C1)"

'copy formual to entire area
Range("D1").Copy Destination:=Range("D1:E" & EndC)

'replace formula with values
Range("D1:E" & EndC).Copy
Range("D1:E" & EndC).PasteSpecial _
Paste:=xlPasteValues

'delete extra rows
Columns("F:G").Delete
Columns("C").Delete

End Sub

 

[Stanley Braverman]

Redid Example

I have column C and column D that contains data. I need macro that will do
IF
THEN with a loop till done;

1st condition. If C1 = D1 then do nothing(but look at next cells C2 and D2
etc. Etc.
2nd condition. If C1 < D1 then move cells in column C down.
(one cell at a time until condition one meet again and continue loop)
3rd condition. If C1 > D1 then move cells in column D down.
(one cell at a time until condition one meet again and continue loop)

Perhaps instead of a loop maybe an input for how many rows to do

By doing this cells that are being moved will leave a bank cell in it's
place and that is what is wanted.
Example: Before After
PS1495-15 PS1495-15 PS1495-15 PS1495-15
PS1495-16 PS1495-16 PS1495-16 PS1495-16
PS1495-17 PS1495-18 PS1495-17
PS1495-18 PS1495-19 PS1495-18 PS1495-18
PS1495-19 PSJT304-16 PS1495-19 PS1495-19
PSJT304-16 PSJT304-17 PSJT304-16 PSJT304-16
PSJT304-17 PSJT304-18 PSJT304-17 PSJT304-17
PSJT304-18 PSJT305-14 PSJT304-18
PSJT314-01 PSJT305-15 PS305-14
PSJT314-02 PSJT314-01 PS305-15
PSJT314-03 PSJT314-02 PSJT314-01 PS314-01

 

[Joel]

I re-wrote my code so it wouldn't effect any other data on your workbook. I
created a newsheet (later deleted) to create the table. I cut the old table
out of the original sheetmoving the data below up to row 1. Then pasted the
new table back into the worksheet.

I written code like you requested (sorting in place) before but its
extremely messy. Much better to use standard Excel VBA functions.

 

[Ross Culver]

What version of Excel are you using?

 

[Joel]

I realized last night when I've done this type of thing in the pasdt it
wasn't with Excel. I was using arrays. the code becomes messy with arays
because you have to push all the data down one location in an array when it
doesn't match. Excel automatically does the pushing of the Arrays (in this
case columns) by using the Insert Command. I like this code better.

Sub CompareStrings()

RowCount = 1
Do While Range("C" & RowCount) <> "" Or _
Range("D" & RowCount) <> ""

StringCompare = StrComp( _
Range("C" & RowCount), _
Range("D" & RowCount), _
vbTextCompare)

Select Case StringCompare
Case -1:
'Column C less than Column D
Range("D" & RowCount).Insert shift:=xlShiftDown
RowCount = RowCount + 1

Case 0:
'column Column C = Column D
RowCount = RowCount + 1

Case 1:

'Column D less than Column c
If Range("D" & RowCount) <> "" Then
Range("C" & RowCount).Insert shift:=xlShiftDown
End If
RowCount = RowCount + 1
End Select

Loop
End Sub