VBA Find Last Point

I

ivandgreat

Board Regular
Joined
Jun 20, 2012
Messages
95
Dears,

I have a table with Start and End, i would like to have a vba that will look up the Last value based on col Start and End.


[TABLE="class: grid, width: 300"]
<tbody>[TR]
[TD]Item[/TD]
[TD]Start[/TD]
[TD]End[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]A001[/TD]
[TD]A002[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]A002[/TD]
[TD]A003[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]A004[/TD]
[TD]A005[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]A006[/TD]
[TD]A007[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]A005[/TD]
[TD]A006[/TD]
[/TR]
</tbody>[/TABLE]

Output table,

[TABLE="class: grid, width: 300"]
<tbody>[TR]
[TD]m[/TD]
[TD]Start[/TD]
[TD]End[/TD]
[TD]Last[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]A001[/TD]
[TD]A002[/TD]
[TD]A003[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]A002[/TD]
[TD]A003[/TD]
[TD]A003[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]A004[/TD]
[TD]A005[/TD]
[TD]A007[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]A006[/TD]
[TD]A007[/TD]
[TD]A007[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]A005[/TD]
[TD]A006[/TD]
[TD]A007[/TD]
[/TR]
</tbody>[/TABLE]


br,
 
Sort by date Sort by votes
Do you mean only delete duplicate results formed by the code and not any original data.

also, What other columns are you referring to ???
 
Upvote 0

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
Yes, only duplicated from output not included the original output.

columns which are related to same row of the table, could be from col D to F or E only.
 
Upvote 0
It seems it is necessary to sort the data (Column B) else there are various results.
This code first sorts the data, and Returns data up to column "F". This does not appear to produce any Duplicates , but if you have some data that does, please supply so I can include code to delete it.

Results start column "G"
Code: 
[COLOR="Navy"]Sub[/COLOR] MG13May14
[COLOR="Navy"]Dim[/COLOR] Rng         [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn          [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dic         [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] oRes        [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] txt         [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] nRay()
[COLOR="Navy"]Dim[/COLOR] c           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] p           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] n           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] st          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Ed          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Lp          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] sTpT        [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
    [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
        Dic.CompareMode = vbTextCompare
Rng.Offset(, -1).Resize(, 3).Sort Range("B2"), xlAscending
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng: [COLOR="Navy"]Set[/COLOR] Dic.Item(Dn.Value) = Dn.Offset(, 1): [COLOR="Navy"]Next[/COLOR]
    [COLOR="Navy"]For[/COLOR] n = 2 To Rng.Count + 1
       sTpT = Range("B" & n)
       txt = Range("C" & n).Value
        p = c
        c = c + 1
        
        ReDim Preserve nRay(1 To 7, 1 To c)
        nRay(1, c) = c
        nRay(2, c) = Range("B" & n)
        Num = Num & c & ","
        nRay(3, c) = txt
        nRay(4, c) = sTpT
        nRay(5, c) = Range("D" & n)
        nRay(6, c) = Range("E" & n)
        nRay(7, c) = Range("F" & n)
        [COLOR="Navy"]Do[/COLOR] Until Not Dic.Exists(txt)
            [COLOR="Navy"]Set[/COLOR] oRes = Dic.Item(txt)
            c = c + 1
             ReDim Preserve nRay(1 To 7, 1 To c)
            nRay(1, c) = c
            nRay(2, c) = txt
            nRay(3, c) = oRes
            nRay(4, c) = sTpT
            nRay(5, c) = oRes.Offset(, 1)
            nRay(6, c) = oRes.Offset(, 2)
            nRay(7, c) = oRes.Offset(, 3)
            
            txt = oRes
            n = n + 1
        [COLOR="Navy"]Loop[/COLOR]
    
     
     [COLOR="Navy"]Do[/COLOR] [COLOR="Navy"]While[/COLOR] c - p > 1
        st = p + 1: Ed = c
        p = c
        [COLOR="Navy"]For[/COLOR] Lp = st To Ed - 1
            c = c + 1
            [COLOR="Navy"]If[/COLOR] Lp = st [COLOR="Navy"]Then[/COLOR] sTpT = nRay(3, Lp)
            ReDim Preserve nRay(1 To 7, 1 To c)
            nRay(1, c) = c
            nRay(2, c) = nRay(3, Lp)
            nRay(3, c) = nRay(3, Lp + 1)
            nRay(4, c) = sTpT
        [COLOR="Navy"]Next[/COLOR] Lp
     [COLOR="Navy"]Loop[/COLOR]
    
[COLOR="Navy"]Next[/COLOR] n
Range("G1").Resize(, 4) = Array("Item", "Start", "End", "StartPt")
Range("G2").Resize(c, 7) = Application.Transpose(nRay)
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
When I ran the previous code on your new data I got the wrong results, because The values are now (Mostly) numbrs and the code was looking for "Text". I have altered the code, as below. the results (Starting column G) I have check for duplicates but there are none.
NB:- Duplicates means Any row where Columns H,I and J Are the same.
Code: 
[COLOR="Navy"]Sub[/COLOR] MG13May09
'[COLOR="Green"][B]Item[/B][/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng         [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn          [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dic         [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] oRes        [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] txt         [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] nRay()
[COLOR="Navy"]Dim[/COLOR] c           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] p           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] n           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] st          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Ed          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Lp          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] sTpT        [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
    [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
        Dic.CompareMode = vbTextCompare
Rng.Offset(, -1).Resize(, 5).Sort Range("B2"), xlAscending
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng: [COLOR="Navy"]Set[/COLOR] Dic.Item(CStr(Dn.Value)) = Dn.Offset(, 1): [COLOR="Navy"]Next[/COLOR]
    [COLOR="Navy"]For[/COLOR] n = 2 To Rng.Count + 1
       sTpT = Range("B" & n)
       txt = Range("C" & n).Value
        p = c
        c = c + 1
        
        ReDim Preserve nRay(1 To 7, 1 To c)
        nRay(1, c) = c
        nRay(2, c) = Range("B" & n)
        Num = Num & c & ","
        nRay(3, c) = txt
        nRay(4, c) = sTpT
        nRay(5, c) = Range("D" & n)
        nRay(6, c) = Range("E" & n)
        nRay(7, c) = Range("F" & n)
        [COLOR="Navy"]Do[/COLOR] Until Not Dic.Exists(txt)
            [COLOR="Navy"]Set[/COLOR] oRes = Dic.Item(txt)
            c = c + 1
             ReDim Preserve nRay(1 To 7, 1 To c)
            nRay(1, c) = c
            nRay(2, c) = txt
            nRay(3, c) = oRes
            nRay(4, c) = sTpT
            nRay(5, c) = oRes.Offset(, 1)
            nRay(6, c) = oRes.Offset(, 2)
            nRay(7, c) = oRes.Offset(, 3)
            
            txt = oRes
            n = n + 1
        [COLOR="Navy"]Loop[/COLOR]
    
     
     [COLOR="Navy"]Do[/COLOR] [COLOR="Navy"]While[/COLOR] c - p > 1
        st = p + 1: Ed = c
        p = c
        [COLOR="Navy"]For[/COLOR] Lp = st To Ed - 1
            c = c + 1
            [COLOR="Navy"]If[/COLOR] Lp = st [COLOR="Navy"]Then[/COLOR] sTpT = nRay(3, Lp)
            ReDim Preserve nRay(1 To 7, 1 To c)
            nRay(1, c) = c
            nRay(2, c) = nRay(3, Lp)
            nRay(3, c) = nRay(3, Lp + 1)
            nRay(4, c) = sTpT
        [COLOR="Navy"]Next[/COLOR] Lp
     [COLOR="Navy"]Loop[/COLOR]
    
[COLOR="Navy"]Next[/COLOR] n
Range("G1").Resize(, 4) = Array("Item", "Start", "End", "StartPt")
Range("G2").Resize(c, 7) = Application.Transpose(nRay)
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Yes there were no duplicates.

How about other rows seems doesn't includes column values from D to F on the output table?

Thanks again.
 
Upvote 0
My results show Data in columns D to F from the Basic Data only.
Do you mean that at the moment, the results for columns D to F show on the ouput table from the basic information, but there is no Data in columns D to F from the code produced results over and above the Basic Data.
If so, what do you want to see in the ouput table for columns D to F???
 
Upvote 0
This bit of code will delete the Duplicates.

It will need to be altered when you decode what gos in columns "E to F" !!!
Code: 
[COLOR=navy]Sub[/COLOR] MG14May08
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] oTr [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] nRng [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Set[/COLOR] Rng = Range(Range("H2"), Range("H" & Rows.Count).End(xlUp))
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
oTr = Dn & Dn.Offset(, 1) & Dn.Offset(, 2)
    [COLOR=navy]If[/COLOR] Not .Exists(oTr) [COLOR=navy]Then[/COLOR]
        .Add oTr, Dn
    [COLOR=navy]Else[/COLOR]
        [COLOR=navy]If[/COLOR] Dn.Offset(, 3) = "" [COLOR=navy]Then[/COLOR]
            [COLOR=navy]If[/COLOR] nRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
                [COLOR=navy]Set[/COLOR] nRng = Dn
            [COLOR=navy]Else[/COLOR]
                [COLOR=navy]Set[/COLOR] nRng = Union(nRng, Dn)
            [COLOR=navy]End[/COLOR] If
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
[COLOR=navy]End[/COLOR] With
[COLOR=navy]If[/COLOR] Not nRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
'[COLOR=green][B]nRng.Interior.ColorIndex = 6[/B][/COLOR]
nRng.EntireRow.Delete
[COLOR=navy]End[/COLOR] If
MsgBox "run"
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
What i mean is that all value in the row table when the logic were done should also reflect the value of col D to F
to the output table on col K to M in related to its respective value of col B to C. Not only the basic data but as well
as all output data.


thanks again.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
summing new value over the previous value based on more than item
2
Replies
12
Views
560
Sahak
S
D
  • Solved
Remove Absolute References
Replies
3
Views
85
HighAndWilder
H
I
  • Solved
Edit working code to look for value after a date & before a date
Replies
6
Views
112
Alex Blakenburg
A
S
  • Question Question
VBA code to determine InDesign Layout
Replies
6
Views
433
Akuini
Akuini
N
  • Solved
Excel 2016 VBA - Pull data from multiple sheets to One with specificities
Replies
3
Views
298
mumps
mumps

Forum statistics

Threads
1,223,786
Messages
6,174,547
Members
452,571
Latest member
MarExcelTips

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top