i have lot of data containing coordinates of Easting and Northing with elevation.they all a have fixed chainage and description (say a point in road center line and few points on both side of it as left side as RHS and right side as RHS and center as CL.now i and distance of each point from a fixed center line and in smaller distance to larger distance order.the LHS offset should be in negative sign.i am attaching one excel sheet for your help
One way...which may or may not work for you...
I selected A B C D an sorted by A, then B
Then in column F i put
=C1-$C$1
and copy it down until the end of that segment (the 0+070's, row 13)
Then i edited each formula to be not absolute anymore, so =C1=C1, =C1=C2, etc
Selected all of those formulas and copied to the bottom
Select column F and copy/paste special/values only
Then select all columns and sort by A then F
You don't get the empty rows however.
Here's a macro to do it for you.
Change the BOLD to however nmany rows you have.
I amde some mistakes while recording this so there's some redundant commands in there
Sub Macro1() ' ' Macro1 Macro ' ' Rows("1:1").Select Selection.Delete Shift:=xlUp Columns("A:E").Select ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1:A132") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B1:B132") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("C1:C132") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Sheet1").Sort .SetRange Range("A1:E132") .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Range("F2").Select ActiveCell.FormulaR1C1 = "=RC[-3]-R1C3" Range("F2").Select Selection.AutoFill Destination:=Range("F2:F13"), Type:=xlFillDefault Range("F2:F13").Select Range("F3").Select ActiveCell.FormulaR1C1 = "=RC[-3]-R[-2]C[-3]" Range("F4").Select ActiveCell.FormulaR1C1 = "=RC[-3]-R[-3]C[-3]" Range("F5").Select ActiveCell.FormulaR1C1 = "=RC[-3]-R[-4]C[-3]" Range("F6").Select ActiveCell.FormulaR1C1 = "=RC[-3]-R[-5]C[-3]" Range("F7").Select ActiveCell.FormulaR1C1 = "=RC[-3]-R[-6]C[-3]" Range("F8").Select ActiveCell.FormulaR1C1 = "=RC[-3]-R[-7]C[-3]" Range("F9").Select ActiveCell.FormulaR1C1 = "=RC[-3]-R[-8]C[-3]" Range("F10").Select ActiveCell.FormulaR1C1 = "=RC[-3]-R[-9]C[-3]" Range("F11").Select ActiveCell.FormulaR1C1 = "=RC[-3]-R[-10]C[-3]" Range("F12").Select ActiveCell.FormulaR1C1 = "=RC[-3]-R[-11]C[-3]" Range("F13").Select ActiveCell.FormulaR1C1 = "=RC[-3]-R[-12]C[-3]" Range("F1").Select ActiveCell.FormulaR1C1 = "=RC[-3]-RC[-3]" Range("F1:F13").Select Selection.AutoFill Destination:=Range("F1:F121") Range("F1:F121").Select Columns("A:F").Select Range("F1").Activate ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1:A132") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B1:B132") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("C1:C132") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("F1:F132") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Sheet1").Sort .SetRange Range("A1:F132") .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1:A132") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("F1:F132") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal Columns("F:F").Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Columns("A:F").Select Range("F1").Activate Application.CutCopyMode = False ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1:A132") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B1:B132") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("C1:C132") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("F1:F132") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Sheet1").Sort .SetRange Range("A1:F132") .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1:A132") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("F1:F132") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Sheet1").Sort .SetRange Range("A1:F132") .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Range("F10").Select End Sub
EDIT: Nevermind this won't work, I thought the categories were the same number of entries eacy (13 row) but they vary.
Last edited by Speshul; 08-21-2014 at 04:03 PM.
You should hit F5, because chances are I've edited this post at least 5 times.
Example of Array Formulas
Click the * below on any post that helped you.Originally Posted by Jacc
This code will work
Sub Macro1() Range("A2:E2").Select Range(Selection, Selection.End(xlDown)).Select Selection.AutoFilter ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Clear ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Add Key:=Range _ ("C2:C65000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ xlSortTextAsNumbers With ActiveWorkbook.ActiveSheet.AutoFilter.Sort .HEADER = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Clear ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Add Key:=Range _ ("A2:A65000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ xlSortTextAsNumbers With ActiveWorkbook.ActiveSheet.AutoFilter.Sort .HEADER = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Range("J65000").Select Selection.End(xlUp).Select Let x = ActiveCell.Row Range("A4").Select Do Until ActiveCell.Row = x If ActiveCell.Value = ActiveCell.Offset(-1, 0).Value Then ActiveCell.Offset(1, 0).Select Else Let Z = ActiveCell.Row Range("A" & Z & ":E" & Z & "").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove ActiveCell.Offset(2, 0).Select End If Loop End Sub
Thank those who have helped you by clicking the Star * below their name and please mark your post [SOLVED] if it has been answered satisfactorily.
the VBA CODE IS NOT RUNNING.IT IS SHOWING NOT RESPONDING AFTER STARTING WELL THEN AFTER FEW MINUTES LATTER IT IS SHOWING RUNTIME ERROR.I OBSERVED MY FRIEND HAD A SHEET WHERE HE JUST PASTED A SHEET SIMILARLY MY ONE AND CLICK ON A BOTTON IT JUST MAKE IT IN PROPER ORDER AND ALSO DISTANCE OF EACH POINT FROM THEIR RESPECTIVE CENTER POINT,THERE THE LEFTHAND SIDE HAVE NEGATIVE VALUE AND HAVE A GAP AFTER COMPLETION OF EACH CHAINAGE ,WHEN I ASKED HE JUST TOLD ME THAT THE DISTANCE FORNULA FOR CHAINAGE 0+070 IS LIKE =SQRT((M$9-M8)^2+(N$9-N8)^2).HE DID NOT SAY ANYTHING MORE SO PLS HELP ME.MAY BE HE IS USING MORE CODE NOT ONE TO MAKE IT SIMILARLY AS I SENT YOU.PLS HELP ME
the vba code is not running.it is showing not responding after starting well then after few minutes latter it is showing runtime error.i observed my friend had a sheet where he just pasted a sheet similarly my one and click on a botton it just make it in proper order and also distance of each point from their respective center point,there the lefthand side have negative value and have a gap after completion of each chainage ,when i asked he just told me that the distance fornula for chainage 0+070 is like =sqrt((m$9-m8)^2+(n$9-n8)^2).he did not say anything more so pls help me.may be he is using more code not one to make it similarly as i sent you.pls help me
Why not just sort the table manually by Chainage and Easting?
Entia non sunt multiplicanda sine necessitate
That is essentially what I did in the macro except I added the space between each unique that was in column A. I think that was the issue at hand that he didn't want to do that manually each time however that's my guess.
please don't use UpperCase, it looks like screaming.
What kind of friend you have, if he is not sharing an working solution with you?I OBSERVED MY FRIEND
Notice my main language is not English.
I appreciate it, if you reply on my solution.
If you are satisfied with the solution, please mark the question solved.
You can add reputation by clicking on the star * add reputation.
ok sir sorry
pls help me me posting it again,
the vba code is not running.it is showing not responding after starting well then after few minutes latter it is showing runtime error.i observed my friend had a sheet where he just pasted a sheet similarly my one and click on a botton it just make it in proper order and also distance of each point from their respective center point,there the lefthand side have negative value and have a gap after completion of each chainage ,when i asked he just told me that the distance fornula for chainage 0+070 is like =sqrt((m$9-m8)^2+(n$9-n8)^2).he did not say anything more so pls help me.may be he is using more code not one to make it similarly as i sent you.pls help me
Since you have replies form several members it is always usefull to add to whom your responding.
Why not ask your friend if he/she has an working solution?What kind of friend you have, if he is not sharing an working solution with you?
Option Explicit Sub test() Dim a, i As Long, ii As Long, w, EAS, NORTH, x As Object, n As Long, Head a = Sheets("sheet1").Cells(1).CurrentRegion.Value ReDim Head(1 To UBound(a, 2) + 1) For i = 1 To UBound(a, 2) If i = 3 Then Head(i) = "OFFET" Head(i + IIf(i > 2, 1, 0)) = a(1, i) Next With CreateObject("System.Collections.SortedList") For i = 2 To UBound(a, 1) If Not .Contains(a(i, 1)) Then Set .Item(a(i, 1)) = _ CreateObject("System.Collections.ArrayList") End If ReDim w(1 To UBound(a, 2) + 1) w(1) = "0+" & Format$(a(i, 1), "") For ii = 2 To UBound(a, 2) w(ii + IIf(ii > 2, 1, 0)) = a(i, ii) Next .Item(a(i, 1)).Add w Next For i = 0 To .Count - 1 For ii = 0 To .GetByIndex(i).Count - 1 EAS = Empty: NORTH = Empty If .GetByIndex(i)(ii)(2) = "CL" Then EAS = .GetByIndex(i)(ii)(4) NORTH = .GetByIndex(i)(ii)(5) Exit For End If Next If Not IsEmpty(EAS) Then For ii = 0 To .GetByIndex(i).Count - 1 w = .GetByIndex(i)(ii) w(3) = Sqr((EAS - w(4)) ^ 2 + (NORTH - w(5)) ^ 2) * IIf(w(2) = "LHS", -1, 1) .GetByIndex(i)(ii) = w Next End If Next Set x = .Clone End With With Sheets.Add.Cells(1).Resize(, UBound(w)) .Value = Head: n = 2 For i = 0 To x.Count - 1 With .Rows(n).Resize(x.GetByIndex(i).Count) .Value = Application.Index(x.GetByIndex(i).ToArray, 0, 0) .Sort .Cells(1, 3), 1 End With n = n + x.GetByIndex(i).Count + 1 Next With .Resize(.Parent.Cells.SpecialCells(11).Row) .Font.Bold = True: .Borders.Weight = 2 .HorizontalAlignment = xlCenter: .Columns.AutoFit End With End With End Sub
many many thanks to you sir,,,,,,,,,,,,,,,,,,,,,,,really u r great
If that takes care of your original question, select Thread Tools from the menu link above and mark this thread as SOLVED.
There are currently 1 users browsing this thread. (0 members and 1 guests)
Posting Permissions
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks