Solved

offset sort overlapping values

Posted on 2010-08-25
3
355 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

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

This tutorial explains how to create a series of drop-down lists that are dependent upon prior selections to guide (“force”) the user to make the correct selection and reduce data errors within Microsoft Excel. Excel 2010 was used for this tutorial;…
Windows Script Host (WSH) has been part of Windows since Windows NT4. Windows Script Host provides architecture for building dynamic scripts that consist of a core object model, scripting hosts, and scripting engines. The key components of Window…
The goal of the video will be to teach the user the difference and consequence of passing data by value vs passing data by reference in C++. An example of passing data by value as well as an example of passing data by reference will be be given. Bot…
The viewer will be introduced to the member functions push_back and pop_back of the vector class. The video will teach the difference between the two as well as how to use each one along with its functionality.

744 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

11 Experts available now in Live!

Get 1:1 Help Now