find move a row up to order
- Thread starter sparcle
- Start date
You didn't copy all of the code I pasted, it sounds like. Whole block of code:
Sub ReorderRows()
Dim xSelect As Range
Dim BRange As Range
Dim CRange As Range
Dim c As Range
Dim firstAddress As String
Dim TimeStamp As Double
Dim DTable As Range
Dim CutRow As Range
TimeStamp = Cells(ActiveCell.Row, "G"
.Value
Set DTable = Selection.CurrentRegion
'Delete this line if AutoFilter is already active
DTable.AutoFilter
'Filter down to just the relevant info based on col G
ActiveSheet.Range("A1".AutoFilter Field:=7, Criteria1:= _
"<=" & TimeStamp
ActiveSheet.Range("A1".AutoFilter Field:=11, Criteria1:= _
"<>X"
With ActiveSheet.AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=Range _
("G1", SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
.Apply
End With
'New Line
Set xSelect = DTable.Offset(1, 0).Resize(DTable.Rows.Count - 1, _
DTable.Columns.Count).SpecialCells(xlCellTypeVisible).EntireRow
'Yes's are in col D and E
Set BRange = Intersect(xSelect, Range("D:D")
Set CRange = Intersect(xSelect, Range("E:E")
If FindAll(Union(BRange, CRange), "YES" Is Nothing Then
'Do nothing
GoTo GetOut
ElseIf FindAll(BRange, "YES".Count = 1 Then
'only 1 YES found
Set CutRow = BRange.Find("YES".EntireRow
ElseIf FindAll(BRange, "YES".Count > 1 Then
'multiple YES found in col B
With BRange
Set c = .Find("YES"
firstAddress = c.Address
'Check for corresponding C value
If c.Offset(0, 1) <> "YES" Then
Do
Set c = .FindNext
Loop Until c.Offset(0, 1) = "YES" Or c.Address = firstAddress
End If
End With
Set CutRow = c.EntireRow
Else
'YES only found in col C
Set CutRow = CRange.Find("YES".EntireRow
End If
'Unfilter
ActiveSheet.ShowAllData
'Mark the row
CutRow.Cells(1, "K".Value = "X"
CutRow.Cut
On Error Resume Next 'do nothing if row was already at top
xSelect.Cells(1, 1).Insert Shift:=xlDown
On Error GoTo 0
GetOut:
'Delete this line if AutoFilter already activ4
DTable.Range("A1".AutoFilter
Application.CutCopyMode = False
End Sub
'Function from Chip Pearson
Function FindAll(SearchRange As Range, _
FindWhat As Variant, _
Optional LookIn As XlFindLookIn = xlValues, _
Optional LookAt As XlLookAt = xlWhole, _
Optional SearchOrder As XlSearchOrder = xlByRows, _
Optional MatchCase As Boolean = False, _
Optional BeginsWith As String = vbNullString, _
Optional EndsWith As String = vbNullString, _
Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FindAll
' This searches the range specified by SearchRange and returns a Range object
' that contains all the cells in which FindWhat was found. The search parameters to
' this function have the same meaning and effect as they do with the
' Range.Find method. If the value was not found, the function return Nothing. If
' BeginsWith is not an empty string, only those cells that begin with BeginWith
' are included in the result. If EndsWith is not an empty string, only those cells
' that end with EndsWith are included in the result. Note that if a cell contains
' a single word that matches either BeginsWith or EndsWith, it is included in the
' result. If BeginsWith or EndsWith is not an empty string, the LookAt parameter
' is automatically changed to xlPart. The tests for BeginsWith and EndsWith may be
' case-sensitive by setting BeginEndCompare to vbBinaryCompare. For case-insensitive
' comparisons, set BeginEndCompare to vbTextCompare. If this parameter is omitted,
' it defaults to vbTextCompare. The comparisons for BeginsWith and EndsWith are
' in an OR relationship. That is, if both BeginsWith and EndsWith are provided,
' a match if found if the text begins with BeginsWith OR the text ends with EndsWith.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim XLookAt As XlLookAt
Dim Include As Boolean
Dim CompMode As VbCompareMethod
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
Dim BeginB As Boolean
Dim EndB As Boolean
CompMode = BeginEndCompare
If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
XLookAt = xlPart
Else
XLookAt = LookAt
End If
' this loop in Areas is to find the last cell
' of all the areas. That is, the cell whose row
' and column are greater than or equal to any cell
' in any Area.
For Each Area In SearchRange.Areas
With Area
If .Cells(.Cells.Count).Row > MaxRow Then
MaxRow = .Cells(.Cells.Count).Row
End If
If .Cells(.Cells.Count).Column > MaxCol Then
MaxCol = .Cells(.Cells.Count).Column
End If
End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
On Error GoTo 0
Set FoundCell = SearchRange.Find(what:=FindWhat, _
after:=LastCell, _
LookIn:=LookIn, _
LookAt:=XLookAt, _
SearchOrder:=SearchOrder, _
MatchCase:=MatchCase)
If Not FoundCell Is Nothing Then
Set FirstFound = FoundCell
Do Until False ' Loop forever. We'll "Exit Do" when necessary.
Include = False
If BeginsWith = vbNullString And EndsWith = vbNullString Then
Include = True
Else
If BeginsWith <> vbNullString Then
If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
If EndsWith <> vbNullString Then
If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
End If
If Include = True Then
If ResultRange Is Nothing Then
Set ResultRange = FoundCell
Else
Set ResultRange = Application.Union(ResultRange, FoundCell)
End If
End If
Set FoundCell = SearchRange.FindNext(after:=FoundCell)
If (FoundCell Is Nothing) Then
Exit Do
End If
If (FoundCell.Address = FirstFound.Address) Then
Exit Do
End If
Loop
End If
Set FindAll = ResultRange
End Function
Sub ReorderRows()
Dim xSelect As Range
Dim BRange As Range
Dim CRange As Range
Dim c As Range
Dim firstAddress As String
Dim TimeStamp As Double
Dim DTable As Range
Dim CutRow As Range
TimeStamp = Cells(ActiveCell.Row, "G"
.ValueSet DTable = Selection.CurrentRegion
'Delete this line if AutoFilter is already active
DTable.AutoFilter
'Filter down to just the relevant info based on col G
ActiveSheet.Range("A1"
.AutoFilter Field:=7, Criteria1:= _"<=" & TimeStamp
ActiveSheet.Range("A1"
.AutoFilter Field:=11, Criteria1:= _"<>X"
With ActiveSheet.AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=Range _
("G1"
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _xlSortNormal
.Apply
End With
'New Line
Set xSelect = DTable.Offset(1, 0).Resize(DTable.Rows.Count - 1, _
DTable.Columns.Count).SpecialCells(xlCellTypeVisible).EntireRow
'Yes's are in col D and E
Set BRange = Intersect(xSelect, Range("D:D"
)Set CRange = Intersect(xSelect, Range("E:E"
)If FindAll(Union(BRange, CRange), "YES"
Is Nothing Then'Do nothing
GoTo GetOut
ElseIf FindAll(BRange, "YES"
.Count = 1 Then'only 1 YES found
Set CutRow = BRange.Find("YES"
.EntireRowElseIf FindAll(BRange, "YES"
.Count > 1 Then'multiple YES found in col B
With BRange
Set c = .Find("YES"
firstAddress = c.Address
'Check for corresponding C value
If c.Offset(0, 1) <> "YES" Then
Do
Set c = .FindNext
Loop Until c.Offset(0, 1) = "YES" Or c.Address = firstAddress
End If
End With
Set CutRow = c.EntireRow
Else
'YES only found in col C
Set CutRow = CRange.Find("YES"
.EntireRowEnd If
'Unfilter
ActiveSheet.ShowAllData
'Mark the row
CutRow.Cells(1, "K"
.Value = "X"CutRow.Cut
On Error Resume Next 'do nothing if row was already at top
xSelect.Cells(1, 1).Insert Shift:=xlDown
On Error GoTo 0
GetOut:
'Delete this line if AutoFilter already activ4
DTable.Range("A1"
.AutoFilterApplication.CutCopyMode = False
End Sub
'Function from Chip Pearson
Function FindAll(SearchRange As Range, _
FindWhat As Variant, _
Optional LookIn As XlFindLookIn = xlValues, _
Optional LookAt As XlLookAt = xlWhole, _
Optional SearchOrder As XlSearchOrder = xlByRows, _
Optional MatchCase As Boolean = False, _
Optional BeginsWith As String = vbNullString, _
Optional EndsWith As String = vbNullString, _
Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FindAll
' This searches the range specified by SearchRange and returns a Range object
' that contains all the cells in which FindWhat was found. The search parameters to
' this function have the same meaning and effect as they do with the
' Range.Find method. If the value was not found, the function return Nothing. If
' BeginsWith is not an empty string, only those cells that begin with BeginWith
' are included in the result. If EndsWith is not an empty string, only those cells
' that end with EndsWith are included in the result. Note that if a cell contains
' a single word that matches either BeginsWith or EndsWith, it is included in the
' result. If BeginsWith or EndsWith is not an empty string, the LookAt parameter
' is automatically changed to xlPart. The tests for BeginsWith and EndsWith may be
' case-sensitive by setting BeginEndCompare to vbBinaryCompare. For case-insensitive
' comparisons, set BeginEndCompare to vbTextCompare. If this parameter is omitted,
' it defaults to vbTextCompare. The comparisons for BeginsWith and EndsWith are
' in an OR relationship. That is, if both BeginsWith and EndsWith are provided,
' a match if found if the text begins with BeginsWith OR the text ends with EndsWith.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim XLookAt As XlLookAt
Dim Include As Boolean
Dim CompMode As VbCompareMethod
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
Dim BeginB As Boolean
Dim EndB As Boolean
CompMode = BeginEndCompare
If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
XLookAt = xlPart
Else
XLookAt = LookAt
End If
' this loop in Areas is to find the last cell
' of all the areas. That is, the cell whose row
' and column are greater than or equal to any cell
' in any Area.
For Each Area In SearchRange.Areas
With Area
If .Cells(.Cells.Count).Row > MaxRow Then
MaxRow = .Cells(.Cells.Count).Row
End If
If .Cells(.Cells.Count).Column > MaxCol Then
MaxCol = .Cells(.Cells.Count).Column
End If
End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
On Error GoTo 0
Set FoundCell = SearchRange.Find(what:=FindWhat, _
after:=LastCell, _
LookIn:=LookIn, _
LookAt:=XLookAt, _
SearchOrder:=SearchOrder, _
MatchCase:=MatchCase)
If Not FoundCell Is Nothing Then
Set FirstFound = FoundCell
Do Until False ' Loop forever. We'll "Exit Do" when necessary.
Include = False
If BeginsWith = vbNullString And EndsWith = vbNullString Then
Include = True
Else
If BeginsWith <> vbNullString Then
If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
If EndsWith <> vbNullString Then
If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
End If
If Include = True Then
If ResultRange Is Nothing Then
Set ResultRange = FoundCell
Else
Set ResultRange = Application.Union(ResultRange, FoundCell)
End If
End If
Set FoundCell = SearchRange.FindNext(after:=FoundCell)
If (FoundCell Is Nothing) Then
Exit Do
End If
If (FoundCell.Address = FirstFound.Address) Then
Exit Do
End If
Loop
End If
Set FindAll = ResultRange
End Function
Hello sir,
With reference to my uploaded workbook some problem arise.
http://www.2shared.com/file/8ckVr-6J/11a.html
sir we write function FindAll for discontinuous values.In my workbook row 8 & 9 has both same value of Col D & E, but row 9 has smaller date value so it want to push up to the row.
But code below
With BRange
Set c = .Find("YES")
firstAddress = c.Address
'Check for corresponding C value
If c.Offset(0, 1) <> "YES" Then
Do
Set c = .FindNext
Loop Until c.Offset(0, 1) = "YES" Or c.Address = firstAddress
End If
End With
Set CutRow = c.EntireRow
finds the first YES value of column D & process.
Sir here i want column D with minimum Date value of Col G will will move up to the order.
Similarly code
Else
'YES only found in col C
Set CutRow = CRange.Find("YES").EntireRow
find first YES in col E & hence process.Here also if there is another YES present with min Date value in col G then also come into consideration.
For this i want sorting condition but it does not give result.
With reference to my uploaded workbook some problem arise.
http://www.2shared.com/file/8ckVr-6J/11a.html
sir we write function FindAll for discontinuous values.In my workbook row 8 & 9 has both same value of Col D & E, but row 9 has smaller date value so it want to push up to the row.
But code below
With BRange
Set c = .Find("YES")
firstAddress = c.Address
'Check for corresponding C value
If c.Offset(0, 1) <> "YES" Then
Do
Set c = .FindNext
Loop Until c.Offset(0, 1) = "YES" Or c.Address = firstAddress
End If
End With
Set CutRow = c.EntireRow
finds the first YES value of column D & process.
Sir here i want column D with minimum Date value of Col G will will move up to the order.
Similarly code
Else
'YES only found in col C
Set CutRow = CRange.Find("YES").EntireRow
find first YES in col E & hence process.Here also if there is another YES present with min Date value in col G then also come into consideration.
For this i want sorting condition but it does not give result.
sparcle,
I'm afraid I'm a little busy at the moment to get all the way back into this. Here's an example on finding the cell address of a minimum. Hopefully you can figure it out.
[pre]
[/pre]
I'm afraid I'm a little busy at the moment to get all the way back into this. Here's an example on finding the cell address of a minimum. Hopefully you can figure it out.
[pre]
Code:
Sub FindMinExample()
Dim BRange As Range
Dim xMin As Date
Dim firstAddress As String
Set BRange = Selection
'Determine the min value
xMin = WorksheetFunction.Min(BRange)
'Find the min value
firstAddress = BRange.Find(xMin).Address
'Just for debugging purposes, print address to Immediate window
Debug.Print firstAddress
End Sub
SirJB7
Excel Rōnin
@SirJB7
Hi, myself!
So long...
Did you know that this topic is the second in number of comments in the whole chandoo history? Discarding the green sticky post "Introduce yourself", the longest is:
#1, 82 posts, http://chandoo.org/forums/topic/need-a-way-to-summarise-data-from-several-worksheets-into-one-place?view=all
#2, 81 posts, this one
#3, much less posts, around 50 I guess
Regards!
Hi, myself!
So long...
Did you know that this topic is the second in number of comments in the whole chandoo history? Discarding the green sticky post "Introduce yourself", the longest is:
#1, 82 posts, http://chandoo.org/forums/topic/need-a-way-to-summarise-data-from-several-worksheets-into-one-place?view=all
#2, 81 posts, this one
#3, much less posts, around 50 I guess
Regards!
hello sir,
problem seems to be much more difficult than i anticipate.
Relating to above post, code below
'Filter down to just the relevant info based on col G
ActiveSheet.Range("A1").AutoFilter Field:=7, Criteria1:= _
"<=" & TimeStamp
ActiveSheet.Range("A1").AutoFilter Field:=11, Criteria1:= _
"<>X"
filter down relevant data.If we can sort these data descending order based on col G which contain dates then BRange get sorting values & when it comes to storing firstAddress it store value which contain min value of col G.
After calculating AutoFilter made of so that only condition fulfill row move to up & other remain where they are.
problem seems to be much more difficult than i anticipate.
Relating to above post, code below
'Filter down to just the relevant info based on col G
ActiveSheet.Range("A1").AutoFilter Field:=7, Criteria1:= _
"<=" & TimeStamp
ActiveSheet.Range("A1").AutoFilter Field:=11, Criteria1:= _
"<>X"
filter down relevant data.If we can sort these data descending order based on col G which contain dates then BRange get sorting values & when it comes to storing firstAddress it store value which contain min value of col G.
After calculating AutoFilter made of so that only condition fulfill row move to up & other remain where they are.
Looking at code I posted
[pre]
[/pre]
We're doing exactly what you stated. Filter down to relevant data, then sorting column G. xSelect is then defined as the block of visible cells.
If you want the min value of col G at this point it would be:
MyMin = WorksheetFunction.Min(Intersect(xSelect,Range("G:G"))
On a side note, it is somewhat frustrating to keep having additional requirements added to this problem. It's much easier to write code when everything is known at the beginning, than to keep making "patches" to code that was written weeks ago. =(
[pre]
Code:
'Filter down to just the relevant info based on col G
ActiveSheet.Range("A1").AutoFilter Field:=7, Criteria1:= _
"<=" & TimeStamp
ActiveSheet.Range("A1").AutoFilter Field:=11, Criteria1:= _
"<>X"
With ActiveSheet.AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=Range _
("G1"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
.Apply
End With
'New Line
Set xSelect = DTable.Offset(1, 0).Resize(DTable.Rows.Count - 1, _
DTable.Columns.Count).SpecialCells(xlCellTypeVisible).EntireRowWe're doing exactly what you stated. Filter down to relevant data, then sorting column G. xSelect is then defined as the block of visible cells.
If you want the min value of col G at this point it would be:
MyMin = WorksheetFunction.Min(Intersect(xSelect,Range("G:G"))
On a side note, it is somewhat frustrating to keep having additional requirements added to this problem. It's much easier to write code when everything is known at the beginning, than to keep making "patches" to code that was written weeks ago. =(
Sorry sir for adding extra condition.It is for last time.
With ActiveSheet.AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=Range _
("G1"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
.Apply
End With
Problem with this code is it sorted the values accordingly,it does not keep other rows in that place after computation over.
With ActiveSheet.AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=Range _
("G1"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
.Apply
End With
Problem with this code is it sorted the values accordingly,it does not keep other rows in that place after computation over.
sir i upload a worksheet.
http://www.2shared.com/file/8ckVr-6J/11a.html
In it suppose i enter data upto SL 4 i.e. to A8 cell, Now i come to know after some time that some data available to me & i enter it.Now the problem arise as this code does not help to move the cell up satisfying the condition.It helps if data are entered in orderly.
Again sorry for dragging into problem.
http://www.2shared.com/file/8ckVr-6J/11a.html
In it suppose i enter data upto SL 4 i.e. to A8 cell, Now i come to know after some time that some data available to me & i enter it.Now the problem arise as this code does not help to move the cell up satisfying the condition.It helps if data are entered in orderly.
Again sorry for dragging into problem.
G
Guest
Guest
B1 http://complex-work. : no links below so it would follow the characteristics of the audience effect.,air jordan pas cherAbercrombie,http://scwifi.net/index.php/User:Fkgftx3ee6#directedlouboutinsb,jordans shoes,http://www.visualclassification.de/index.php/User:Fkgfsy0bv0#com_.5BEditor_can_the,ralph lauren pas cher,air jordan, but there are still so many people take the risk. Scattered the rain my heart ,air jordans shoes, Related articles: http://bbs. php?php/2012/02/11/ http://shequ.title=User:83059137414#let_me_give_you_a_c http://mandurainmotion.
,abercrombie france,You must have something to say,louboutin pas cher,michael kors handbags. com/wordpress/how-to-solve-a-problem-like-akismet-false-positives/ Henceforth will I recognize that each day I am tested by life in like manner. php?gain. mountain onion Water Pik. amazing,michael kors outlet, Or grim to Xuerouhengfei the smile at the last minute alone? 93.
ralph lauren,http://www.nakedwiki.biz/index.php?title=User:Fkgftg5uq8#E6_I_lost_the_phone,polo ralph lauren pas cher, 9C. com/asian/hot-videos/ http://www. Xiao lu. if I continue to try,lancel, miss the dream.Not far away is a cable-stayed bridge.com/identification/index. mod=viewthread&tid=72928&pid=248291&page=34&extra=page=1#pid248291 Henceforth will I recognize that each day I am tested by life in like manner. in the organizers opinion.
,abercrombie france,You must have something to say,louboutin pas cher,michael kors handbags. com/wordpress/how-to-solve-a-problem-like-akismet-false-positives/ Henceforth will I recognize that each day I am tested by life in like manner. php?gain. mountain onion Water Pik. amazing,michael kors outlet, Or grim to Xuerouhengfei the smile at the last minute alone? 93.
ralph lauren,http://www.nakedwiki.biz/index.php?title=User:Fkgftg5uq8#E6_I_lost_the_phone,polo ralph lauren pas cher, 9C. com/asian/hot-videos/ http://www. Xiao lu. if I continue to try,lancel, miss the dream.Not far away is a cable-stayed bridge.com/identification/index. mod=viewthread&tid=72928&pid=248291&page=34&extra=page=1#pid248291 Henceforth will I recognize that each day I am tested by life in like manner. in the organizers opinion.
Hi sparcle,
I'm afraid I don't think I can offer any more help on this problem. It's grown so long in length that I've lost track of what's going on and what exactly we're trying to do. =(
My recommendation would be to start a new thread, with a link to your uploaded hyperlink, and exaplin clearly EVERYTHING that you need to be going on. You could also include a link to this thread as a reference. I think this problem is really just a sorting issue where you're having trouble figuring out the order to sort the columns.
I'm afraid I don't think I can offer any more help on this problem. It's grown so long in length that I've lost track of what's going on and what exactly we're trying to do. =(
My recommendation would be to start a new thread, with a link to your uploaded hyperlink, and exaplin clearly EVERYTHING that you need to be going on. You could also include a link to this thread as a reference. I think this problem is really just a sorting issue where you're having trouble figuring out the order to sort the columns.