Solved

offset sort overlapping values

Posted on 2010-08-25
3
363 Views
Last Modified: 2012-05-10
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
Comment
Question by:thmh
  • 2
3 Comments
 
LVL 17

Expert Comment

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

If 1 = 2 Then

0
 
LVL 17

Accepted Solution

by:
calacuccia earned 300 total points
ID: 33522882
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
 

Author Closing Comment

by:thmh
ID: 33523157
tnx , works perfectly
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
The viewer will learn how to clear a vector as well as how to detect empty vectors in C++.
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.

920 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

16 Experts available now in Live!

Get 1:1 Help Now