VBA macro to add flag to column, with predefined parameters

[NickWels]

Hi

I need help with a VBA macro. a few steps and logic.
File already open via import from text

4 step message box:
1. Enter value
2. Enter symbol
3. Choose column for flagging
4. Choose column to match

The value entered (usually around 1000-2500) will be used to add the symbol in the chosen column for every multiple instance, but to the nearest populated row in another chosen column
i.e 1000 entered = 1000,2000,3000, and so on to end of doc but would be something like 1005, 2008, 2999, 4001 when matched against the other column

I've created a 20k sample file. In sample file. Add flag to C, to the nearest * populated in A

Data will have a sequence column if this will be useful for anyone to use, feel free..

Many thanks for any help!

[Aflatoon]

FYI, cross-posted: https://www.excelforum.com/excel-programming-vba-macros/1436790-vba-macro-to-add-flag-to-column-with-predefined-parameters.html

[June7]

Not understanding. Enter value and symbol where? Are these the data already in file? Choose columns how? What should results look like?

[jindon]

so many msgbox...


Sub test()
Dim myList, i&, s(1), x(1), myRow&, myItem, LR&
myList = Array(Array("Symbol", ""), Array("Item", ""), Array("Flag", ""))
LR = Cells.SpecialCells(11).Row
Application.DisplayAlerts = False
For i = 0 To 2
On Error Resume Next
myList(i)(1) = Application.InputBox("Select column for " & myList(i)(0), Type:=8).Column
If myList(i)(1) = "" Then Exit Sub
myList(i)(1) = Range(Cells(2, myList(i)(1)), Cells(LR, myList(i)(1))).Address
On Error GoTo 0
Next
s(0) = InputBox("Enter Symbol"): If s(0) = "" Then Exit Sub
If Application.CountIf(Range(myList(0)(1)), s(0)) = 0 Then MsgBox "No symbol found", , s(0): Exit Sub
If Not IsNumeric(s(0)) Then s(0) = Chr(34) & s(0) & Chr(34)
s(1) = Application.InputBox("Enter Value", Type:=1)
x(0) = Evaluate("max(if((" & myList(0)(1) & "=" & s(0) & ")*(" & myList(1)(1) & _
"+0<=" & s(1) & ")," & myList(1)(1) & "+0))")
x(1) = Evaluate("min(if((" & myList(0)(1) & "=" & s(0) & ")*(" & myList(1)(1) & _
"+0>=" & s(1) & ")," & myList(1)(1) & "+0))")
If x(0) = 0 Then
myItem = x(1)
Else
If s(1) - x(0) < x(1) - s(1) Then
myItem = x(0)
Else
myItem = x(1)
End If
End If
myRow = Evaluate("match(" & myItem & "," & myList(1)(1) & "+0,0)")
Cells(myRow + 1, 3) = "x"
Application.Goto Cells(myRow, 3)
End Sub

[NickWels]

Thanks Jindon for your help with this! Much appreciated :)
It correctly enters the first symbol value, but can you add code to loop through to the end of the file and add the symbol for every increment of the entered value?
i.e 1000 entered would flag around 1000,2000,3000 till end

[jindon]

If the code is not working as you want, I don't think I understand what you are trying to do.

It will help if you upload a workbook showing your desired results in new sheet with every parameters.

[NickWels]

Sorry mate, not the best at explaining this!
I have uploaded a new doc to this reply. Column C has a # populated every 1000 rows to the nearest populated cell in Column A (if I were to enter 1000 in 'Enter Value' msg box)

Hope this helps?

[jindon]

The difference between csv in post #1 and post #7 is one have 2002 ros\ws and other have only 5988 rows and they are exactly the same up to 5899 row.

What are the parameters you enter?

[NickWels]

I trimmed the file so it has less rows, now at 6k~. Enough rows to test the code but not so many that for entering manually would take long
I manually entered the # in column C to show the desired results

Select column for symbol: $A:$A
Select column for item: $B:$B
Select column for flag: $C:$C
Enter symbol: *
Enter Value: 1000

[jindon]

OK
When * is entered to symbol and 1000 entered to the value, my code finds nesarest value that have same symbol that is 0000000998 on row 999 and place "x" to col.C.

Did you check above?



i.e 1000 entered would flag around 1000,2000,3000 till end
Sorry, but I don't understand the meaning of above...

[NickWels]

I'm not sure how best to explain... but can the code loop through the search ot the next 1000 = 2000~ and then 3000~

So the data file is flagged with x in Ccol C every 1000~ rows until end of file
My attachment (attached to this reply) will show the flags in col C every 1000 to nearest 8 in Col A
Pic of data with applied filter to also show this
http://www.vbaexpress.com/forum/image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAQQAAACyCAIAAAArjiaBAAAQAElEQVR4Aexdb2wb x5UfKfl0 hAXgb9GaUPGbqRWDqq2MAmf3TQ9hXQb/0PdOj6fYBgn QwkUm0YrVIlaVDVukbnHGXjXIkHn6tT3VxV2I7TMxn3TxqdIBltVUS6SoYs0qmVr0Fh5wABkROU 997M7P9ZcklxJNF8i H efvmzdvfztuZWe5vt/ZvaCIECAGOQC2jiRAgBDgCFAwcBpoRAozpCoZPf/rTFQ0v b 6p29V8NcVDPfdd//qornM0sn/ZQK4zOyrgr YLhvmXAEyq5N6b77yH9t4AYwvCr46wsGahkCnHNtKqtyZS3j0ayK/ UMhi984QsmHKsS2Wbpy18h/5eP4XIsrAr ZQsGiIRnnnnGPH7dkb3r9NTU6V1mcWVf0eY/Oj4lpzeONZTdcWlQm//CfsOxN QxaDoNevy3gw/ u/EvTzC4IgEAu/9 nX3uhmMH68fG6p/QFw06/X9veP8mnF5eONCrKxx0 g9V6vzWUXEMmzbtv/UpDadBm/8G HACAP/zjitqGYLBGwkQDHoiGwxjanhqKxsdGBitP6irLrH7VuBu2Pyt9/BotPz0 b/r9Ev1w/ufPjkr/Z49efKSXC3jQp//lpOXnt308tgWWx1abjAoIwHK09nn47Hw5uzsm6Ns61OaOho6/Qd4MMnDwNXy/7T5v uJLWPnzEgov PSojb/pX25uPTW2ENWHVpWMPhFApSkMbLNSqQzGjT6zx46cB46rFPQ1ejSVqt0 d/wqXo4u/qTLv/zel56MOSJBChRX2SbscCYxmjQ5z9jRrf13MPOLivAVraky//ZdxfK5mM Q7r8V5S58K7R4ysxGPJHApSoLbJ3HT7wkLy0Tk2dx/XDGsZv7L4VGDNAG83qP6Wnn6fN//lb723ReOMCqg5P2vzn1o0Z3IjZMvaWOeQpJRgKRgKUpSuyoctqXFjhfgDcyxjWc250 Q/QmAmOhVmXJVNclhVt/s ePDe25SVxE4Z72nDsmIarkTb/uc981nDsjfMH2PCAGQvFP6gXJBKgrPvv1/IPNNSf90bfNJo1KAd6SlqiQZP/4DEzxgxTeFfmWetU8H3lmmn0H27C7B ufwmHPfjrZW9qOAZt/pu9Chyz7d9k3RUD5ItrGQJGAtjVFNlwIhzuw7jh5NObNNQoTf4zBkfAmzScuQ4FYCtb0uY/93AWQMcDwJ eg9Djvx38Tc5AwOMqIhiCRwIYXpk HxSkKZH/moANaHZV8C8iGH7/ 993FprMQ9UT2aZ57Svkv3aI8xawKvgXEQx5nXfvXJXIdjuxjG3yfxnglSHrSuDvcVNfMOh8Nslz GGUXrMqVqYxHQf6XAGZtQ0PjZz7z2aamTY8//rnPfe7zn//8F7/4xc2bN0ej0b/dsmXb1q1PfOlLT375y3/3la/EWlq2x2Jf2759x9e tmvHjj27du3ds ebX//6M9/4xt/v2/cP /cfPHDgUGvrPx482H7o0D999rMb/rWSJ/J/dc/equBfOzs786c//e/09NQ77/zxj3/8wx/ 8Lvf/e7atWvj4 P/Mzb29ujoW7/97a9/85tf/upX6atXr6TTv7hy5fIvfnHp8uULly6NXLjwXz// U9/9rOfvPbaf54/f254 OzQ0L fOzd49uyPIC7b29vbKnZqaWmpWN/RcfIfUSjyp6ubBMGQy VgTokQeO3CfxebVgU0jcGwKsdDha5NBL6556vB02odQmUFw2qhROUuGwHoJgRPyy6tNAMUDKXhR rmKQyB4IIBmcabLp70iwZBuj9aIKdqezlrOZ/vNHTXR9n5rT7bfyADZjD0OIcgxRW2ZmFPByMacckvMWLodbZi/9rTpmuUKiFAN9znti2zcAVQQm3yOuqJQvhcsGIkr8t2GhC9V HBVbo7PrEy oGEOS40bFjPcwY2ImXAKhGJF6BhzfoyeHVm7h3bIjWwFlzCAtKcTP3xFpB/0/vD7Pzjxve/3vPi9l7/7wovffv55UCtoTZNCwGDYdXpqyk2fDupRuj2ebExl4CAzqcZkvFWCCWcj3Mm6UY67utlIuMZ LiMJvgvzdPI8oY5xUMzlMokIa0vx1dx4R8jphsyVy6T2znSGLXtSblmT2aScWxuMSSHLXjHW7Mt 8DqjtTHT2WQEG8dGTtNuT6z74MKawWQg0adKzsJvyYGbTzl4ZmYhE2MgV 9Ug3R6Oz zlZyOXQVg9wWKz4LMK13t7 s7x47m/5j7 OOPYLr70UdLd5f41NvzA1DzsaFdXDgYGvBFCE/cGi6Vr5udn2FtO2NYaUOx44m2Rn5M2f6eJJyhQS4HSSg2OJSIJHtkpIBEJswTmbiekZtBF6HY9r 0Rr3Iwa1AlvFlLkMCdPdsRpfs6GVQ0tx01Pm4tvh0YNK5dwgwOfKKtu7txwhYNotAhedUJdcBps u8OWEqOQSV3pO98 /jHdz/66O5dDASY3V364T/3CrWANsuuVjgY BOKz765rJKTr8tKHuoYHERYEfXI3u0YIabhEFTfEmA28ztWsuk uMY9FnYIA26gcwFVC6jtPJ5gsnHAOoX1TJnDg49SC/3SCxq0C3Ddiu1ss86Dp1BsH/M1LkrX2V9z0BK40wsvdn/IG4SlpQ9feeUVU0dtQr 0cDAs1we4lqTaoMtSUxPFEYPV/jY 6ogFxkKPNjJPGwC1unMCzlBANyY6w7xnHI4nWWLIGW1gwmPN0IdMRp8KT38b6BaVFHYwf6iju40 3DtgsJI6b/TDcJ3 DCVzWCgSdPWwmbKv4/DD3wn OiIBjDiKRRkRSZHoyCu/3wOYbC0tPThh0t2hSJtl01dfzBAJY8NQm8fevGNM/Fw2P9kOA9Knj/oriYyVm/eqePdgq5XTkyZvSNha9DgZ83Sz8lCRJXwWs4v8dqR tAzZJ2t0Z5kWzc2iVLqWEAXUYmPr01H7kAbNlO V3Vx4BALjLmjQZQBAxa4ZvBkXDjEjgBzd6NgtAJL0DRAWlqyKwSwp0VlJYJBOB6KdQyOZxIRswW embdaCa6CveeI2bMxzh9W6qABxM3IGV6UWfJ1OYANbA2rBEvGpZEyLNCPiQmmbhZs9j342PZZqw VAsxSLXpMHzut6DbSr5nliTBYaG SXGTiHRRuXI4Z/OXkS0okTvS 88OLRY0ehNVjC6cO7S0uwbqbizZcnh/ZgwHt1Vl02ekKq8QGeDXeXGA6SVybbgA5Ey0iFrHEn4D7WMorwZMVK5H89hrvIXnw8NlBQALTwY xGj2qJ2kT/jwHl9h1lKjhu8hWauT1iXrKCliJbgW986uri4 MH/fXD7zu2 vpMgxFiAEfTdu7BupqBGy62nPRg4mDCI5K0AjiLx1hJ0naAzDV0X828HuJPdCmMDZVdC3WgXQCK bhvtVoiynZl5rvEq4BvbO7OXe8sFHWQyPZLxhzMGEP1DS7TbQHJaU fMIPQcOoSXaBlFoa386i9nhPMWTiksW7sv34wMEvPR/t7v79u3bif5 IfmPH/94aHj4J d/KjbFPJ8hnfu0BwMTA8Q4H9eGRxrNAQBcLzMJ1sPlNTXhHgZ3smW33X3A5olx7/BuQ4CJhj4ct5Xl0HNYM/UhF0Qm3E4p4UyDeacdEAROfvgw wDa AcmL2hwn8dENEjxls/Rdrz35rgI8NASDXJsEP6eGZFnsIclMr7NnH pGAeipufYv535kX3Tu 5vRu eoMEAN1hLZn6LASI0vbncOL xahwS3GiFkSPf4dwDp9X f5pzE7eUUYM7hDE N8tCue38WZtQtbimnMGfHvC/nk1T olq9gLRgH2boYK0gQu z6PEjaEm38235EyJD2qiMfmzMhmgpeCOV NO1/0yY6fjeWEwpT4oaRtPC9zicOngARgipYfS 2ALs6ggK8FMll8raDCUv2SyuDwE4HotG1ZryLE8izpzey//eSQ6HclnWxfTLV ZtK88CBjNgHH9Lo9VPVbSv/x18KTHhcJWNTLdChdOGtWBwL49Xy02aQCmsEmN3aSFSp4AuUp2H98OTP4Xi4DGYKiv5AmCoZLdx/fGk//FIkBjBqj2lAgBRIDGDIgC/QgBQEBjNwmsUyIEKgiBNR0MFYQjuXoPILBywZBur4Q/h9bEKbVozlHrWWmlkAGqNXyyc7s9B5HtF4ZAW7KsPCokYK6PlTT37ltcPIzp4kYTneBCM4tzJZu 23gIA69aGU422BALp9nCnoBxnkDMuLiFKIYRC3KCXd7POsBU5wpI5z1xn5qPxppBW3AjYW4bW2G j81ta6gbq6gSNs23TvelQOLkRtn9/8lfZoPDnR2dreN8/CIR8tEiMC6deTTBKBQrFB SS1UsiQANJm0Mt3tvk wA16jUgrNJZYDP28CNiCoXVH/dVXr01ynaET0yweamYsuJDnU85CsY7tj7FIW1uEPXa8w3gFgFKVhC4E8BFbz9sQDCGyQ5Kv85Y2 C Gift4WuletnRPJeDQaFUv7O3lcpVX5pi0YHEhM3r4ZWuf EGVwocMWY m 693jg4Pj3df7qqjP6gIh4GYMLvGyhjNO2cYLvlLIGLQciRn bHW4h6WMN1g4Cwp1DHa3RRKZ8fFxsXQ8OOzUrfItWzDM3vig5ehmaA0AktaL21pgwVhwIVf3mcU GxSPIsPQjAvvkrEIx1PA2UcOjffM7ExGGXRylEMbF8ZG9/IVGmW4W9x8zcBPYq0JTVQhpwEO2BcNk12tHbjaN8gH00RvTV7N3ZhkLLgxYIKkVRoC/QCGHNIMO6103XiGy0 TogvEXQkGD4jEOvSQYriV7oJcUht5ST967Tp7c1SWwBQMc NBuHD3DALppbl3Lzdty/BBYCBYolRUBrO8ewrFS6Fes7CUNQS8pBb2lIZPy5JehiuXOYDCA2HjxzLpTJ aMTbEMLhT6NC8JAej71ETFyIoPGfi1Xynk42f5DkKhii89UhXKe0dwL0m1j2QmAvZgaN48zftIi 4uP39j6WpdoF4ILTZu0shwEkBPdOMKp4TAqToh3RimFMH6GfyLcqp6ySw0Cj6F7XmAPhslrTfxP hro6IxLg8IMLQZlSORAIGcMDOzFcKYShwqBkkft3f0Id4/z2BSwrgRNXDgRLtGEPhhJNUDZC4N5AgPgM98Z5pKMoAwLEZygDiGTi3kBAYzepWAbqmtKHs7um/CnWGfK/WMRAX2MwFMtAXVP6UJnWlD/FOkP F4sY6NOYAaoNJUIAEaAxA6JAP0IAENDYTQLrlAiBCkKAgqGCTha5qheBlQuGwvxbvUe6hq3bnjz iXuKTppzYXCOoy/5CBqgamuJ5Jq7rnkEBnBIK2nm03LmqblsEQ2tscXFfr6AycAiK5j2jhVgrz uZZYkD7cHEFGTT/chAM7cZ1O9SONB7Z4gDbQOxpNXa9b3Thxd33DklPwbDjRTNe17fexRfaMgzq2bEgVahgrJ0X8/17u5EBNfFLx2cAw2qkcRxzqPFb4sw/CeRqAAAEABJREFUvyk7P2M8t8qXfnrVLq99v6tpoG63PRSK5j039z4ZT01f9YWSONC 0LDY4PhgzGLweBQNurNjhyG0fYXEn MAfS7BfSYOtANExYboJil2GKKCvOfmzWfjtw513TYyqJZp4kCrYFHKlHRnpVBm51 kDY80EgdaAlLyQhUMxfCeN14cfTh16JrgPvh6EasGDrTv0Re5Q0l3VgqFYWgfcjniQAswljVXBU Nw3nPrxW3siI38sCxXKLOBAPSdcjiND blQBvquCQONKKwzJ8qGMBkIDJ08 ajLazlzGF8A9/ithZWf8Z5SwrsUFoeAsqhgCGEG6bGV0D9SyEOtD827j0 wWCo5eU9WyS4gbq6t6 yhSN2ipxhgpbFIYBVnDjQxWFWJm1lMBDvuUzoFjSDNb mJtw5IT/6DH NKenOSiHciiIOdEGIi1CQwQA3WG1df uSX0holTS3uy49ZG3SWiAEQh2SwoxDBPgJsrIxZlhRDnQgf 9tJRkM9/ZB0tERAkEQID5DEJRIpyoQID5DVZxmOsggCGjsJi1U8gTYVbL79B3oUs6exmCor QJgqGS3cfHJqvL/3IcLY0ZoNpTIgQQARozIAr0IwQAAY3dJLBOiRCoIAQoGCroZJGrehFYuWAg/q3qTGYBFg JOdvfHjWEaSOXWqjKbuSwlln6DrQFhv aoH2KzzKU8u3njRdF3sXD0 JTuYqifDjQCs1qE2X7W PJxhR lS2zd6azlbP10 1BOdDK7CoMM9fZY3nodKos1Sirbd7w6kAdfpbhwqlHtl0UlP7gHOjmT9w4IrK/ffO5PTK7F0fiQHsxQUnm kTERmKeGLmSZengHGhVdqaYiAOtAEUhqk3vlo/XvX8h9cEjG9eDTuuO quvSvLa0IlpFg81MzUxmk1e65LZ5y77kqCJAw2gKlNsMOf4foiXrm/QnR3ZDWHh7JANulfEgQYcAiTbmKFhwwM359535ynIgZYZNu5oWbgsA0OKrAVxoC0sfNYMxg5T0p 2VQrslM7tdyNclu4e A83RyDszgqG5d98Z9rZoJYrhQLPWi4Lp9snLeR7hJg503pMg3pXEEuKr5kq6s1JoGsVhhpHdFNp XeJNj9JbsO2jdhgAGA7466Sz7dd1u XnP4BxoMGQQRP 8I98YGhTvtVS 44F7PfFkW8rqMBl8hmAcaE92h2fQS4rGk8meaDQa7pyAZTsfpTt0aEMggHeTnmSHBpq6HB0ko4o PNM2ta7l5W7z8QikUZhib231kIbThQWOTlgERgKoc7mxM5Titx5NH2fuxC/NnB3uylzQ0Pj6eaoskhiDAQiCmpECg9skNr9robG6NvBxoxpp7N4v7T4yt7z1an73xF7cB2s6Hg KzKGXskgKwmGAeagSoGkiO7sjijl6TcSUIDgdoHjNdb8K7/9Ga4ccQCc6An59adkf8z7ImnLriaF6MMWvogkO7rnGAsGQ Lf9hgXhQHWpndWxQMFbxCkigQqBX/EhjzJn5HdTLwB6GH0vw/CsxOkaCAN78Ibo3mnBNvIpSffFYIfbK7ywzRd6DdkPhs4wDaZxeJ72UE6Ni8CBCfwYsJSaoUAeI zVOmJp8P2IqCxm1QKC3XN5AGk1owvpThC/peAmsZgKAcrddVsQGVatbLLUTD5XwKKNGaAakOp4hDQ4jCNGbTASkYrEQGN3aRKhIN8rmYEKBiq ezTsTsQWLlgSLfLJ24c5Vf9BsBSw6eo9TgpPmnKZfQd6BWtH7VqEnNz7z7 PZ7Di4WI0dJb g60BKK4RbrdzoEOtyP9H8kJM3szuVwuk2pMxsUlRClkquwqB4gDrULFI6tVkZiDc6ClPXxkVa4q F8iBjicnOlvb ZZmB4hNkBKv56M2DjQDCeQsbbuDgQphJQef2I00qUj7uxMMWXnZxofBYPGUqFCIkCgVkFiLoIDD RbwQe4n46lpXwo0Iw40h0kxi1kcaDtJwaZp0J1tIsYMYeHskA36XMSBBhwCJGvM4ENiLsiBbt58 Nn7rUNftfIURBzovOu0wQAiPNKY47VNJd1YKpc20I7sUWgvJ7iEOtAWJ31qtgsRcDAd648XRh1O HrgkqnF8hjDjQvtDADrjAw/igm8XFmAH7RjOc4xDtm9 ZiDDs4iiFkBeSKztIvAlNMOoleYFxSGrZ0G5kI9TVWSTm4Bxo g60A8zlbNg/5FwcB5qXas/OBcYMeknEgTbAKLC0uklzdhLzkIyQvBzoqvoOdAEcS9qd7Y/W8BtIvrmVIwlDWDg72JW9JOJAAxaFUm1 EnNeDrRFiIO25e2rbOFIXR46dSFPqnB/6NFGluwRb6vIIomzbWcMic0BOdDK7EoYjV6ScicJDQRqVSTmwBxowwotS0MgNgh/JYxwCnS4hyU4sz/UMZRqdMmYUghDMW92ryMwVPAKSaJAoFZFYrYu bYrvVJoWZzbneclYpYarTkRgL8SxuHvNUjWO1xUMrg/PehRZD5SVxEd44Ja3TFuvZrJqUJbHAFrzMA3aUYIVC8CxGeojnNPRxkAAeIzBACJVKoDAY3dpBJ IqGsnC5z9teNMCZ6Q/yWApjEYSiChrp0sUJnWjjMleEL lwAajRmg2lAiBBABGjMgCvRb4wisjHsau0krcwBUCiFQLgQoGMqFJNmpeARWLhjSxIFW1BZORqi Rk/nQHj5qymVRU8RYcKGnnGy/METnwAONXYBf7jks6c6Lh61v1yKnmcvFFxtEFqUQdqF8Xy9 2QE2vCmbTmcNKaxbG4awupdtqZyc FMTWOtbOzkJOoMcaBkO2f6gQgWaxIFWgOIVYcuwcAS/Az1QVzcgPnCIHys5w4TwyM2mUfFOgObN014hw /BLe64c8qs7d4iQEIcaABBlbLzMxH358rxCW1Bgg5JghvkDC4EZXeCUoznVvnSvZ 2BQK1D24IiTVr3rznYXZqUnzGdujEdLblk62MKYWMvd/VNFC3WxEKljlGHGgbGN7Vkb6o6BKJZ7lZ5vqEGSDhxyJsZh7gDS50FwC9K JAu0FRb2PLUC8/RSVaAMYaNjxwc8743uHk7Zs8p1LI9wSYpfuud48PDo53X TZzxApmpQgTo 0bhzCLpJmQTr5LRPuIxbR46UBdwKLkRtx0 ye4gD7UBFuVE7t1v2kS6cemTbdO96xtZvfOSDG7Om9l9uZNdtbFYKTZ1CK8SB9kEI cuDMWybQx3dbaIR8FFdlpj3jiCi HJZlu7lzNgyiON7v vQNIuHmtn7czcf2NAghDCHftSduUmlEPZSKicCE9czzGgMuF2ov3wZXMjVbTPoJREH2oZHvlUrG BhrWBcyPvn8yMb1MlfzJx7J3hHthFIo1WhRAgJwx9PJgeZjBRgnYFBwe9CN4i/HMF VhNL8QtSw/WQviTjQNkz8Vmtjxu3U9b1H669engNFGDSz55ph0Azrrc83sVR2kjGlEBTu0bQihxXavjeS7Onn 95qz/T3JyN7t0GOSUhg1Z/nb9XbGwJngQlD2JN47MloZz14SSARqWcsZ/n/C4p546oK8tTp57dApyY0 w95u6uKDaaVQWqFFaQgIajN/R5L5EjGGhOcEZ0GH4zNtKfnnA6gGFLpdoSBwI K3reRAMzbZ9Rr87YBpN7YVIrdSyHfBDVYbW5qLaBYIATvfmQ keS7o2wjCs2AvcxnEiGRBFxQKfWMeIg60AUWBpX3MUECVdhMC9zYCxGe4t88vHV0RCBCfoQiwKk eVPC0FAY3dpBJIqGsnC2C5dpwpwRPyvwTQNAZDCSTUtZMFKtPacaYET8j/EkCjMQNUG0qEACJAYwZEgX6EACCgsZsE1ikRAqUgsEp5KBhWCXgqdu0hsHLBQPxb1dlXcqDxSVP O96kR1GWREQA0hIIU4sjLd0XFDqFvm2f7hSEw4aNhU67eVR8OdHPvPkmMNhg/AFFwISjbUpY40DY0PKtuDnS6PSwo0DnOgZYVPN0eTzamMkgD6maCBoRkCNiWKdXGxAOungIYIw6 0AhSvCFsGDwe6NTYav7WVk36OMMH4Yax589nn7khidH6htxTiQHsx4ZKslwPNn1R1fwcaP07I2n byp5c4M5pzQbkJOYNskcRxfMCVeSYoxXhulS89CiTgCNQ 6OVAK78DjWyHq3 WxOjLC6END2L hnUhrxB32H/Egbaj4Vl3c6AdCga5Adk9ydfFw95Y7/nD3jZNlUzshj4XcaAFFIXm2DK4OdCOPJO3b4bWIe9t9o54MwDsxWjhzAdmChmzhKDhSsSBdgFib GauT7g50PKNGFlU4R96E2TQ2GAqMSMe9u5hqaGOEO43fhYZwpBYy1DHYHdbJEEcaAsSvzUFB5rN 3vig5ehm8Rqk1ovbWkTeyWtNW 8cXUTyw9EbFvNBIRT69jlxoO1o2Nax2 /mQEO1bxPVPto3vzMR4SMBGALHR/bikCGX6WZx/uoA0471HhlT5FrhvSOjt TaR5sGAtgyiHWTA41kBnxdkqz301c57RNHz2fZIT6QOMSeXOQDa6VQmKN5CQhIumfMJC50hIUVe 3UPxY4nItBlEntgzndyPhxsuBP0kogD7QbFZ9sKBoajAoMDPbQb3ylWVzfQNLeuBYXr98TZqUPX JrmZya53ruLLlJRCrkGzIAjA5V7BgbbnxHrOidF2oWvd GauSyw3ZS JONASj3wLFQfapm9 B/r9Cyn23PMb5a7WT7Zgc6EUShVaFEZAEpvFsNjgQGOEyNupfMjAX67Hx8/uL0aLAmDojPeZxIbP3Ogl ewmsUBAyYFu3jzN 0iLi4/f2Cr5nJNdr8FtVvnnwxl2pAlbCaVQGK6s Sp5G oYSjWOiGHxSKMYFgtZGP9EC/ewREZwoGOD8KfDiFsKbkMsRPxuqTI wVCBL2lWCAElBxrGynxsUFcnI0FYMftOdXVpcY8V5EohyCkFQiBkjA9y42IgDbnsMuuukVrKYAg bilBbk8iDrQHEh Bfczgo0JiQqA6EKBgqI7zTEcZAAEKhgAgkUp1IKCR6VYCCXXtZIGzv3acKeiJV4H892JSUKKR6V YCCXXtZIHKtHacKcET8r8E0KibBNWGEiGACFAwIAr0IwQAAQoGAIESIYAIUDAgCvRbVQTWSuEUD GvlTJAfq45AbcOxN6bM6fQu6ZAlNUWMBRdKK7QgBCoJAWwZxl7eJKdnL3Hfd50 v3V0P5e9zF564xgS3SAUeg8sCE1LqNTkNmhGCFQaArWPPvyQ2 ddT2wZO3dSfMft0sAw2/oURgMojr0lguXSW2MPPfwoZFNrwg5KhEDlIYAtw5aXRD/J1iOyDmT23QVR8edvvbflCdGNwhiQcWEpMlPTJqNVQqByEKi99CzvDm3atH 4XvaIsNofFH0jtuv0S1vE0cyefHr/rYM8bA7e2i86VGpNoU9zQqDCEMCWQbg8e7JL9oig2r 8cOC8rPfDY /dmhej517WxSOni/VO8fJMB6oAAAClSURBVGZEqSnM0ZwQqDQErGBgDEYFC /KoYLRXjz97sNbUNjw1FY23CUHErMnz40ZXSazZTE0Kw0B8pcQkAjUnuaXeNhqOHZwizFChk2RoJ dUPzwAw bZN0fZgcNiyMAYDBp4cyGU NzU5Fs0IwQqD4FaZgyf8W6qGAnAXdQ3eB9paurgrf1Pi YAe0RMjrSnXmIvC3GD S FpVl5IJDHhAAi8P8AAAD///hkflkAAAAGSURBVAMADQEYiCSySs8AAAAASUVORK5CYII=

[jindon]

Detailed error checking has not been implemented...


Sub test()
Dim myList, i&, s(3), x(1), myRow&, myItem, LR&
myList = Array(Array("Symbol", ""), Array("Item", ""), Array("Flag", ""))
LR = Cells.SpecialCells(11).Row
Application.DisplayAlerts = False
For i = 0 To 2
On Error Resume Next
myList(i)(1) = Application.InputBox("Select column for " & myList(i)(0), Type:=8).Column
If myList(i)(1) = "" Then Exit Sub
myList(i)(1) = Range(Cells(2, myList(i)(1)), Cells(LR, myList(i)(1))).Address
On Error GoTo 0
Next
s(0) = InputBox("Enter Symbol"): If s(0) = "" Then Exit Sub
If Application.CountIf(Range(myList(0)(1)), s(0)) = 0 Then MsgBox "No symbol found", , s(0): Exit Sub
s(2) = s(0): If Not IsNumeric(s(2)) Then s(2) = Chr(34) & s(0) & Chr(34)
s(3) = Application.InputBox("Enter Value", Type:=1)
s(1) = s(3)
Application.ScreenUpdating = False
Do
myRow = GetNearestRow(myList, s, LR)
If myRow > 0 Then
Cells(myRow, 3) = "x"
s(1) = s(1) + s(3)
End If
Loop While s(1) <= LR
Application.ScreenUpdating = True
End Sub


Function GetNearestRow&(myList, s, LR&)
Dim x(1), myItem
If s(1) = 21000 Then Stop
x(0) = Evaluate("max(if((" & myList(0)(1) & "=" & s(2) & ")*(" & myList(1)(1) & _
"+0<=" & s(1) & ")," & myList(1)(1) & "+0))")
x(1) = Evaluate("min(if((" & myList(0)(1) & "=" & s(2) & ")*(" & myList(1)(1) & _
"+0>=" & s(1) & ")," & myList(1)(1) & "+0))")
If (x(0) = 0) + (x(1) = 0) Then
myItem = Application.Max(x(0), x(1))
Else
If s(1) - x(0) < x(1) - s(1) Then
myItem = x(0)
Else
myItem = x(1)
End If
End If
If myItem = 0 Then GetNearestRow = 0: Exit Function
GetNearestRow = Evaluate("match(" & myItem & "," & myList(1)(1) & "+0,0)") + 1
End Function

[arnelgp]

not very good with excel and the code is ugly.
please try anyway.

[jindon]

NickWels (http://www.vbaexpress.com/forum/member.php?87060-NickWels)

Optimized the function, resulting in a significant speed increase


Sub test()
Dim myList, s(2), a, i&, ii&, t&, myRow&, myItem, x&
myList = Array(Array("Symbol", ""), Array("Item", ""), Array("Flag", ""))
Application.DisplayAlerts = False
For i = 0 To 2
On Error Resume Next
myList(i)(1) = Application.InputBox("Select column for " & myList(i)(0), Type:=8).Column
If t < myList(i)(1) Then t = myList(i)(1)
If myList(i)(1) = "" Then Exit Sub
On Error GoTo 0
Next
s(0) = InputBox("Enter Symbol"): If s(0) = "" Then Exit Sub
s(1) = Application.InputBox("Enter Value", Type:=1)
Application.ScreenUpdating = False
With [a1].CurrentRegion.Resize(, t).Offset(1)
a = .Value2
ReDim b(1 To UBound(a, 1), 1 To 1)
Do
s(2) = s(2) + s(1)
If s(2) > UBound(a, 1) Then Exit Do
x = GetNearestRow(a, s, myList)
If x Then b(x, 1) = "x"
Loop
.Columns(myList(2)(1)).Value = b
End With
MsgBox "done"
Application.ScreenUpdating = True
End Sub


Function GetNearestRow&(a, s, myList)
Dim i&
For i = 0 To s(1) - 1
If s(2) + i <= UBound(a, 1) Then
If a(s(2) + i, myList(0)(1)) = s(0) Then GetNearestRow = s(2) + i: Exit For
End If
If a(s(2) - i, myList(0)(1)) = s(0) Then GetNearestRow = s(2) - i: Exit For
Next
End Function

[NickWels]

Jindon you beauty... this works perfectly and is so fast!
Thank you very much for understanding the request and excelling in a solution, much appreciated :)

[jindon]

Glad it worked and thanks for the feedback.