Solved

offset sort overlapping values

Posted on 2010-08-25
3
394 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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

Salesforce Made Easy to Use

On-screen guidance at the moment of need enables you & your employees to focus on the core, you can now boost your adoption rates swiftly and simply with one easy tool.

Question has a verified solution.

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

How to get Spreadsheet Compare 2016 working with the 64 bit version of Office 2016
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 demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

630 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