Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

offset sort overlapping values

Posted on 2010-08-25
3
Medium Priority
?
402 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 1200 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

Hire Technology Freelancers with Gigs

Work with freelancers specializing in everything from database administration to programming, who have proven themselves as experts in their field. Hire the best, collaborate easily, pay securely, and get projects done right.

Question has a verified solution.

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

When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
In Part II of this series, I will discuss how to identify all open instances of Excel and enumerate the workbooks, spreadsheets, and named ranges within each of those instances.
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.

782 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