Solved

# offset sort overlapping values

Posted on 2010-08-25
371 Views
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
Question by:thmh
• 2

LVL 17

Expert Comment

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

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
.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
``````
0

Author Closing Comment

ID: 33523157
tnx , works perfectly
0

## Featured Post

Question has a verified solution.

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

### Suggested Solutions

A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

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

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