• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 414
  • Last Modified:

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
0
thmh
Asked:
thmh
  • 2
1 Solution
 
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
 
thmhAuthor Commented:
tnx , works perfectly
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Keep up with what's happening at Experts Exchange!

Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now