Solved

offset sort overlapping values

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

Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
Although Jacob Bernoulli (1654-1705) has been credited as the creator of "Binomial Distribution Table", Gottfried Leibniz (1646-1716) did his dissertation on the subject in 1666; Leibniz you may recall is the co-inventor of "Calculus" and beat Isaac…
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…

828 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