View Single Post
 
Old 01-26-2016, 12:30 AM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 22,382
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

There is no apparent relationship between the before & after data structures in your link, especially regarding your expressed desire for "closeness of + 0.2 and re-arrange values based on match". That said, try the following macro. It will reorganise the data on sheet1 in the attachment as shown on sheet2, which I believe agrees with your expressed desire for "closeness of + 0.2 and re-arrange values based on match", even though the result is quite different from the expected output shown in your link. The same macro should also work with your most recent data.
Code:
Sub Demo()
Application.ScreenUpdating = False
Dim lRow As Long, lCol As Long, r As Long, c As Long, Rng As Range, sTmp As Single
With ActiveSheet
  .UsedRange
  With .Cells.SpecialCells(xlCellTypeLastCell)
    lRow = .Row
    lCol = .Column
  End With
  For c = 1 To lCol
    Set Rng = .Range(.Cells(1, c), .Cells(lRow, c))
    With .Sort
      .SortFields.Clear
      .SortFields.Add Key:=Rng, SortOn:=xlSortOnValues, _
        Order:=xlAscending, DataOption:=xlSortNormal
      .SetRange Rng
      .Header = xlNo
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
    End With
  Next
  r = 0
  Do While r < lRow + 1
     r = r + 1
    sTmp = .Cells(r, 1).Value
    For c = 2 To lCol
      If .Cells(r, c).Value > sTmp Then sTmp = .Cells(r, c).Value
    Next
    For c = 2 To lCol
      If .Cells(r, c).Value > 0 Then
        If .Cells(r, c).Value < sTmp Then sTmp = .Cells(r, c).Value
      End If
    Next
    For c = 1 To lCol
      If .Cells(r, c).Value > 0 Then
        If .Cells(r, c).Value - sTmp > 0.2 Then .Cells(r, c).Insert _
          Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
      End If
    Next
    .UsedRange
    lRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
  Loop
End With
Application.ScreenUpdating = True
End Sub
Attached Files
File Type: xlsm Data Sort.xlsm (18.7 KB, 12 views)
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote