Sorting

D

dervishyou

I'm having a hard time with this problem. Please help!
Example:

I need the following to sort:

A1= Green B1= 1 C1=0 D1=1
A2= Blue B2= 5 C2=1 D2=0
A3= Yellow B3= 0 C3=0 D3=0
A4= Red B4= 3 C4=3 D4=0

Since cell A3 Yellow and its values in the row B3, C3 & D3 are zero I
need to replace it with A4 Red... To something likes this:

A1= Green B1= 1 C1=0 D1=1
A2= Blue B2= 5 C2=1 D2=0
A3= Red B3= 3 C3=3 D3=0

Above is just an example of hundreds of these charts. Currently I have
to use the "cut-and paste" method and as you know it's not very
productive. Any advise will be greatly appreciated.

Henry Nguyen
 
G

Guest

This code will remove all rows where columns B, C and D have a value of zero,
which in effect moves the row below it up into where the deleted row as at.

Press [Alt]+[F11] to open the VB Editor, choose Insert | Module from its
menu and copy and paste the code below into it. Close the VB Editor. Use
Tools | Macro | Macros to run the code on the currently active sheet.

Sub RemoveAllWithZeroValues()
Const columnWithName = "A"
Dim lastRow As Long

lastRow = Range(columnWithName & _
Rows.Count).End(xlUp).Row
Do Until lastRow = 0
If Range(columnWithName & lastRow).Offset(0, 1).Value = 0 _
And Range(columnWithName & lastRow).Offset(0, 2).Value = 0 _
And Range(columnWithName & lastRow).Offset(0, 3).Value = 0 _
Then
Range(columnWithName & lastRow).EntireRow.Delete
Else
lastRow = lastRow - 1
End If
Loop
End Sub
 
G

Guest

If you have groups of these on a single sheet and need to preserve empty row
spaces between them (where there isn't an entry as Green, Red, Blue, Yellow),
then this routine will work a bit better for you. The earlier routine also
removes rows that have no entry at all in B, C and D.


Sub RemoveAllWithZeroValues()
Const columnWithName = "A"
Dim lastRow As Long

lastRow = Range(columnWithName & _
Rows.Count).End(xlUp).Row
Do Until lastRow = 0
If Not IsEmpty(Range(columnWithName & lastRow)) Then
If Range(columnWithName & lastRow).Offset(0, 1).Value = 0 _
And Range(columnWithName & lastRow).Offset(0, 2).Value = 0 _
And Range(columnWithName & lastRow).Offset(0, 3).Value = 0 _
Then
Range(columnWithName & lastRow).EntireRow.Delete
Else
lastRow = lastRow - 1
End If
Else
lastRow = lastRow - 1
End If
Loop
End Sub
 
D

dervishyou

If you have groups of these on a single sheet and need to preserve empty row
spaces between them (where there isn't an entry as Green, Red, Blue, Yellow),
then this routine will work a bit better for you. The earlier routine also
removes rows that have no entry at all in B, C and D.

Sub RemoveAllWithZeroValues()
Const columnWithName = "A"
Dim lastRow As Long

lastRow = Range(columnWithName & _
Rows.Count).End(xlUp).Row
Do Until lastRow = 0
If Not IsEmpty(Range(columnWithName & lastRow)) Then
If Range(columnWithName & lastRow).Offset(0, 1).Value = 0 _
And Range(columnWithName & lastRow).Offset(0, 2).Value = 0 _
And Range(columnWithName & lastRow).Offset(0, 3).Value = 0 _
Then
Range(columnWithName & lastRow).EntireRow.Delete
Else
lastRow = lastRow - 1
End If
Else
lastRow = lastRow - 1
End If
Loop
End Sub











- Show quoted text -
Click to expand...

Hello JLatham,

You are a genius! Your code worked perfectly with my posted example!
This was the first time I tried VB in macro and, to be honest, I was
at first greatly intimidated.

I'm sorry but I did not post my challenge in details because I thought
the solution would be some sort of formulas that I can actually tweak.
I have absolute zero knowledge with Visual Basic. Please be patient
with me one more time....

The actual challenge should look something like this on the excel
sheet:

A1= Product Name xxx
A2= Product Code xxx
A3= Green B3= 1 C3=0 D3=1
A4= Blue B4= 5 C4=1 D4=0
A5= Yellow B5= 0 C5=0 D5=0
A6= Red B6= 3 C6=3 D6=0
A7= blank

Only rows A3 to A6 need to be sorted and ALL 7 rows need to be
preserved for formatting purpose. There are hundreds of these and they
are to be printed on papers that are specifically formatted.

Would you please be take another look at it?

Best regards,,
Henry Nguyen
 
G

Guest

Try this code in a copy of your workbook to make sure things work, but I
think it will do the job for you. It does not physically delete rows, it
just moves the data in groups to remove zero-row entries.

Sub RemoveAllWithZeroValues()
Const columnWithName = "A"
Const lastDataColumn = "D"
Dim lastRow As Long
Dim testRow As Long
Dim lastGroupRow As Long
Dim baseCell As Range ' will be A# in each row
Dim destRange As Range
Dim srcRange As Range
Dim LC As Integer ' loop counter

lastRow = Range(columnWithName & _
Rows.Count).End(xlUp).Row
testRow = lastRow ' save for use later
Application.ScreenUpdating = False ' prevent flicker
Do Until lastRow = 0
Set baseCell = Range(columnWithName & lastRow)
If Not IsEmpty(baseCell) Then
'some entry in column A, must also be
'numeric entries in columns B, C and D
If (Not IsEmpty(baseCell.Offset(0, 1)) And _
baseCell.Offset(0, 1).Value = 0) _
And (Not IsEmpty(baseCell.Offset(0, 2)) And _
baseCell.Offset(0, 2).Value = 0) _
And (Not IsEmpty(baseCell.Offset(0, 3)) And _
baseCell.Offset(0, 3).Value = 0) _
Then
'must erase this information and if there
'is information on the row immediately
'below it, that must be moved into it's place
'along with any data in the group below it.
lastGroupRow = baseCell.End(xlDown).Row ' blank row
If IsEmpty(baseCell.Offset(1, 0)) Then
'special case at bottom of list
lastGroupRow = lastRow
End If
If lastRow >= lastGroupRow Then
'just erase current, there's nothing below it
For LC = 0 To 3
baseCell.Offset(0, LC) = ""
Next
Else
'have data to move
Set srcRange = Range(columnWithName & lastRow + 1 & _
":" & lastDataColumn & lastGroupRow)
Set destRange = Range(columnWithName & lastRow)
srcRange.Cut
destRange.Select
ActiveSheet.Paste
End If
Else
lastRow = lastRow - 1
End If
Else
'empty row, has no entry in col A
lastRow = lastRow - 1
End If
Loop
Application.ScreenUpdating = True
End Sub
 
D

dervishyou

Try this code in a copy of your workbook to make sure things work, but I
think it will do the job for you. It does not physically delete rows, it
just moves the data in groups to remove zero-row entries.

Sub RemoveAllWithZeroValues()
Const columnWithName = "A"
Const lastDataColumn = "D"
Dim lastRow As Long
Dim testRow As Long
Dim lastGroupRow As Long
Dim baseCell As Range ' will be A# in each row
Dim destRange As Range
Dim srcRange As Range
Dim LC As Integer ' loop counter

lastRow = Range(columnWithName & _
Rows.Count).End(xlUp).Row
testRow = lastRow ' save for use later
Application.ScreenUpdating = False ' prevent flicker
Do Until lastRow = 0
Set baseCell = Range(columnWithName & lastRow)
If Not IsEmpty(baseCell) Then
'some entry in column A, must also be
'numeric entries in columns B, C and D
If (Not IsEmpty(baseCell.Offset(0, 1)) And _
baseCell.Offset(0, 1).Value = 0) _
And (Not IsEmpty(baseCell.Offset(0, 2)) And _
baseCell.Offset(0, 2).Value = 0) _
And (Not IsEmpty(baseCell.Offset(0, 3)) And _
baseCell.Offset(0, 3).Value = 0) _
Then
'must erase this information and if there
'is information on the row immediately
'below it, that must be moved into it's place
'along with any data in the group below it.
lastGroupRow = baseCell.End(xlDown).Row ' blank row
If IsEmpty(baseCell.Offset(1, 0)) Then
'special case at bottom of list
lastGroupRow = lastRow
End If
If lastRow >= lastGroupRow Then
'just erase current, there's nothing below it
For LC = 0 To 3
baseCell.Offset(0, LC) = ""
Next
Else
'have data to move
Set srcRange = Range(columnWithName & lastRow + 1 & _
":" & lastDataColumn & lastGroupRow)
Set destRange = Range(columnWithName & lastRow)
srcRange.Cut
destRange.Select
ActiveSheet.Paste
End If
Else
lastRow = lastRow - 1
End If
Else
'empty row, has no entry in col A
lastRow = lastRow - 1
End If
Loop
Application.ScreenUpdating = True
End Sub













- Show quoted text -
Click to expand...

Hi JLatham,

Once again, you did it! It works flawlessly.
Thank you for helping me.

I have another challenge for you but I'm not quite sure if I should
start it in a new post... so others may be able to benefit from it.
It's going to be a "horizontally" sorting challenge. Here it is:

A1= Product Name
A2= Product Code
A3= Green
A4= 1
A5= Blue
A6= 5
A7= Yellow
A8= 0
A9= Red
A10= 3

To;

A1= Product Name
A2= Product Code
A3= Green
A4= 1
A5= Blue
A6= 5
A7= Red
A8= 3

Again, there are hundreds of these rows.

Thank you

Henry Nguyen
 
D

dervishyou

Hi JLatham,

Once again, you did it! It works flawlessly.
Thank you for helping me.

I have another challenge for you but I'm not quite sure if I should
start it in a new post... so others may be able to benefit from it.
It's going to be a "horizontally" sorting challenge. Here it is:

A1= Product Name
A2= Product Code
A3= Green
A4= 1
A5= Blue
A6= 5
A7= Yellow
A8= 0
A9= Red
A10= 3

To;

A1= Product Name
A2= Product Code
A3= Green
A4= 1
A5= Blue
A6= 5
A7= Red
A8= 3

Again, there are hundreds of these rows.

Thank you

Henry Nguyen- Hide quoted text -

- Show quoted text -
Click to expand...

Sorry, I made a big mistake. Should be:

A1= Product Name
B1= Product Code
C1= Green
D1= 1
E1= Blue
F1= 5
G1= Yellow
H1= 0
I1= Red
J1= 3

To:

A1= Product Name
B1= Product Code
C1= Green
D1= 1
E1= Blue
F1= 5
G1= Red
H1= 3

Thank you.

Henry Nguyen
 
G

Guest

BTW: contrary to some forums, it's preferred in these to top post rather than
bottom post. Works out better for this type of discussion.

I presume in this second challenge that there is only one data group per
row; that I don't have to look out beyond column J for anything?
 
D

dervishyou

Hi JLatham,

Yes, one data group per row and J is the last column.

Thank you

Henry Nguyen
 
D

dervishyou

Hi JLatham,

Yes, one data group per row and J is the last column.

Thank you.

Henry Nguyen

PS: hope this message is properly top posted.
 
G

Guest

Ok, (and yes, it showed up at the top - I know, hard to keep up with all the
different "rules" at various sites). With that in mind, try this out on a
copy of your data. I think it'll work for you. Actually must easier and
more straightforward than the earlier task. Essentially it starts looking at
the right end of the row, if a value is zero for the qty, then the color &
qty cells are simply deleted and anything to the right is shifted in to the
left. Repeat for all 4 pairs of color/values and in the end you end up with
a 'condensed' list on the row.

Sub CompressRows()
'change constants to fit your worksheet
Const firstRow = 2 ' first row with data
Const ProdNameColumn = "A" 'column w/Product Name in it

Dim lastRow As Long
Dim LC As Long ' loop counter
Dim prodCell As Range

lastRow = Range(ProdNameColumn & _
Rows.Count).End(xlUp).Row
' make it faster (and no flicker)
Application.ScreenUpdating = False
If lastRow >= firstRow Then
For LC = firstRow To lastRow
Set prodCell = Range(ProdNameColumn & LC)
If prodCell.Offset(0, 9) = 0 Then ' J#=0
Range("I" & LC & ":" & "J" & LC).Delete _
shift:=xlToLeft
End If
If prodCell.Offset(0, 7) = 0 Then
Range("G" & LC & ":" & "H" & LC).Delete _
shift:=xlToLeft
End If
If prodCell.Offset(0, 5) = 0 Then
Range("E" & LC & ":" & "F" & LC).Delete _
shift:=xlToLeft
End If
If prodCell.Offset(0, 3) = 0 Then
Range("C" & LC & ":" & "D" & LC).Delete _
shift:=xlToLeft
End If
Next
End If
Application.ScreenUpdating = True
End Sub
 
G

Guest

Lucky me - two 'flawlessly's in a row <g> Probably time to quit while I'm
ahead.

Glad to have been able to help.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Protecting user from changing previous data 5
PLEASE HELP TO MATCH ALL SHEET AND THEN MERGE, 1
Round up & Autosum 1
LOOPING STRUCTURE DESIRED 4 TWO RANGES 2
how do i filter data on one worksheet and display on another. 1
Vlookup and multiple data 5
Please suggest any formulae / functions 2
If Statement - Help Needed 4

Top