offset sort overlapping values

hy ,
have macro that sorts values to grid , need to adjust macro so if overlapping values occurs values don't get replaced but sorted to offset grid

example in attachment
Book87.xls
thmhAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

calacucciaCommented:
Hmm, why do you have this in your macro? It seems difficult for this condition to be true :-)

If 1 = 2 Then

0
calacucciaCommented:
This should do the job, error message if all grids are full.


Sub Sort_2_cols_to_grid()
    ' ********************************************
    ' ** Assumptions
    ' ********************************************
    ' ** - Data Starts in Row 23.  Last Row is calculated by macro
    ' ** - Values in Column A and F are same
    ' ** - Values in Column C and H are same
    ' ** - Values are in columns A, B, C, F, G, H
    ' ********************************************
On Error GoTo skip1
    
    Dim DataFirstRow As Long
    Dim DataLastRow As Long
    Dim DataCurrentRow As Long
    
    Dim ResultFirstRow As Long
    Dim ResultLastRow As Long
    Dim ResultCurrentRow As Long
    
    Dim ResultFirstCol As Long
    Dim ResultLastCol As Long
    Dim ResultCurrentCol As Long
    
    Dim RowTitle As String
    Dim ColTitle As String
    Dim Result1 As String
    Dim Result2 As String
    
If Range("B27") = "" Then GoTo skip1
    
    DataFirstRow = 27
    DataLastRow = [A65536].End(xlUp).Row
  
    
    ' Rows("1:1").Select
    ' Selection.Delete Shift:=xlUp
    ' Selection.Insert Shift:=xlDown
    
    ResultFirstRow = 1 ' Row 1
    ResultFirstCol = 6 ' Column F
    
    'Range("G2:AT21").ClearContents
    
    
    ' First we set up the Row titles in row 1
    '   these row titles are from Column C (3) and H
    '   and will start from Column G(7)
    If 1 = 2 Then
        ResultCurrentRow = 1
        ResultCurrentCol = 7
        For DataCurrentRow = DataFirstRow To DataLastRow
            ColTitle = Cells(DataCurrentRow, 3)
            If IsError(Application.Match(ColTitle, Range(Cells(ResultFirstRow, ResultFirstCol), Cells(ResultFirstRow, ResultCurrentCol)), 0)) Then
                Cells(ResultCurrentRow, ResultCurrentCol) = ColTitle
                ResultCurrentCol = ResultCurrentCol + 2
            End If
        Next DataCurrentRow
        ResultLastCol = ResultCurrentCol - 1
    Else
        ResultLastCol = 54
        ResultLastRow = 25
    End If '1=2
    
    
    ' Next we set up the Row titles in Column F (6)
    ResultCurrentRow = 2 - 1
    ResultCurrentCol = 6
    For DataCurrentRow = DataFirstRow To DataLastRow
        RowTitle = Cells(DataCurrentRow, 1)
        'If IsError(Application.Match(RowTitle, Range(Cells(ResultFirstRow, 6), Cells(ResultCurrentRow, 6)), 0)) Then
        '    ResultCurrentRow = ResultCurrentRow + 1
        '    Cells(ResultCurrentRow, 6) = RowTitle
        'End If
        
        ' Next we pick up the data in a loop
        '   from Columns A (1), B (2), C (3), and G (7)
        '   Locate the result Row and Columns using Match
        '   and then Paste the Result Data
        ColTitle = Cells(DataCurrentRow, 3)
        ResultCurrentCol = Application.Match(ColTitle, Range(Cells(ResultFirstRow, ResultFirstCol), Cells(ResultFirstRow, ResultLastCol)), 0)
        ResultCurrentRow = Application.Match(RowTitle, Range(Cells(ResultFirstRow, ResultFirstCol), Cells(ResultLastRow, ResultFirstCol)), 0)
        
        'Cells(DataCurrentRow, 2).Copy
        'Cells(ResultCurrentRow, ResultCurrentCol + ResultFirstCol - 1).Select
        'ActiveSheet.Paste
        'Cells(DataCurrentRow, 7).Copy
        'Cells(ResultCurrentRow, ResultCurrentCol + ResultFirstCol).Select
        'ActiveSheet.Paste
        Result1 = Cells(DataCurrentRow, 2)
        Result2 = Cells(DataCurrentRow, 7)
        'Check if Grid is empty
        If IsEmpty(Cells(ResultCurrentRow, ResultCurrentCol + ResultFirstCol - 1)) = True Then
            Cells(ResultCurrentRow, ResultCurrentCol + ResultFirstCol - 1) = "'" + Result1
            Cells(ResultCurrentRow, ResultCurrentCol + ResultFirstCol) = "'" + Result2
        Else
            'Check Second grid to the right
            If IsEmpty(Cells(ResultCurrentRow, ResultCurrentCol + ResultFirstCol - 1 + 24)) = True Then
                Cells(ResultCurrentRow, ResultCurrentCol + ResultFirstCol - 1 + 24) = "'" + Result1
                Cells(ResultCurrentRow, ResultCurrentCol + ResultFirstCol + 24) = "'" + Result2
            Else
                'Check Third grid (left bottom)
                If IsEmpty(Cells(ResultCurrentRow + 12, ResultCurrentCol + ResultFirstCol - 1)) = True Then
                    Cells(ResultCurrentRow + 12, ResultCurrentCol + ResultFirstCol - 1) = "'" + Result1
                    Cells(ResultCurrentRow + 12, ResultCurrentCol + ResultFirstCol) = "'" + Result2
                Else
                    'Check Fourth grid (right bottom)
                    If IsEmpty(Cells(ResultCurrentRow + 12, ResultCurrentCol + ResultFirstCol - 1 + 24)) = True Then
                        Cells(ResultCurrentRow + 12, ResultCurrentCol + ResultFirstCol - 1 + 24) = "'" + Result1
                        Cells(ResultCurrentRow + 12, ResultCurrentCol + ResultFirstCol + 24) = "'" + Result2
                    Else
                        MsgBox "All grids are full for this fixture"
                    End If
                End If
            End If
        End If
    Next DataCurrentRow
    
    If 1 = 2 Then
        For ResultCurrentCol = ResultFirstCol + 1 To ResultLastCol Step 2
            Range(Cells(ResultFirstRow, ResultCurrentCol), Cells(ResultFirstRow, ResultCurrentCol + 1)).Select
            Application.CutCopyMode = False
            With Selection
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
                .WrapText = False
                .Orientation = 0
                .AddIndent = False
                .ShrinkToFit = False
                .MergeCells = False
            End With
            Selection.Merge
        Next ResultCurrentCol
    End If '1=2

' centar grid delet character

    Range("G2:BB25").Select
    Selection.Replace What:=" '", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:=" """, Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:=" ¤", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
        ReplaceFormat:=False
   Cells.Select

skip1:

End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
thmhAuthor Commented:
tnx , works perfectly
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.