CODEWITHSUNDEEP
vbaexcel
DevilWAH
DevilWAH

Reputation: 2643

pulling out data from a colums in Excel

I have the following Data in Excel. 

CHM0123456  SRM0123:01  
CHM0123456  SRM0123:02  
CHM0123456  SRM0256:12  
CHM0123456  SRM0123:03  
CHM0123457  SRM0789:01  
CHM0123457  SRM0789:02  
CHM0123457  SRM0789:03  
CHM0123457  SRM0789:04

What I need to do is pull out all the relevent SRM numbers that relate to a single CHM ref. now I have a formular that will do some thing like this 

=INDEX($C$2:$C$6, SMALL(IF($B$8=$B$2:$B$6, ROW($B$2:$B$6)-MIN(ROW($B$2:$B$6))+1, ""), ROW(A1)))

however this is a bit untidy and I really want to produce this same using short vb script, do i jsut have to right a loop that will run though and check each row in turn. 

For x = 1 to 6555
if Ax = Chm123456 
string = string + Bx
else
next

which should give me a final string of

SRM0123:01,SRM123:02,SRM0256:12,SRM0123:03

to use with how i want.

Or is ther a neater way to do this ?

Cheers

Aaron

my current code

    For x = 2 To 6555
If Cells(x, 1).Value = "CHM0123456" Then
outstring = outstring + vbCr + Cells(x, 2).Value


End If


Next
MsgBox (outstring)

End Function

Upvotes: 2

Views: 675

Answers (2)

Gaijinhunter
Gaijinhunter

Reputation: 14685

I'm not sure what your definition of 'neat' is, but here is a VBA function that I consider very neat and also flexible and it's lightning fast (10k+ entires with no lag). You pass it the CHM you want to look for, then the range to look in. You can pass a third optional paramater to set how each entry is seperated. So in your case you could write (assuming your list is :

=ListUnique(B2, B2:B6555)

You can also use Char(10) as the third parameter to seperat by line breaks, etc.

Function ListUnique(ByVal search_text As String, _
                    ByVal cell_range As range, _
                    Optional seperator As String = ", ") As String

Application.ScreenUpdating = False
Dim result As String
Dim i as Long
Dim cell As range
Dim keys As Variant
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")

On Error Resume Next
For Each cell In cell_range
    If cell.Value = search_text Then
        dict.Add cell.Offset(, 1).Value, 1
    End If
Next

keys = dict.keys
For i = 0 To UBound(keys)
    result = result & (seperator & keys(i))
Next

If Len(result) <> 0 Then
    result = Right$(result, (Len(result) - Len(seperator)))
End If

ListUnique = result
Application.ScreenUpdating = True

End Function

How it works: It simple loops through your range looking for the search_string you give it. If it finds it, it adds it to a dictionary object (which will eliminate all dupes). You dump the results in an array then create a string out of them. Technically you can just pass it "B:B" as the search array if you aren't sure where the end of the column is and this function will still work just fine (1/5th of a second for scanning every cell in column B with 1000 unique hits returned).

Upvotes: 2

Jon49
Jon49

Reputation: 4606

Another solution would be to do an advancedfilter for Chm123456 and then you could copy those to another range. If you get them in a string array you can use the built-in excel function Join(saString, ",") (only works with string arrays).

Not actual code for you but it points you in a possible direction that can be helpful.

OK, this might be pretty fast for a ton of data. Grabbing the data for each cell takes a ton of time, it is better to grab it all at once. The the unique to paste and then grab the data using

vData=rUnique

where vData is a variant and rUnique is the is the copied cells. This might actually be faster than grabbing each data point point by point (excel internally can copy and paste extremely fast). Another option would be to grab the unique data without having the copy and past happen, here's how:

dim i as long
dim runique as range, reach as range
dim sData as string
dim vdata as variant

set runique=advancedfilter(...) 'Filter in place
set runique=runique.specialcells(xlCellTypeVisible)
for each reach in runique.areas
 vdata=reach
 for i=lbound(vdata) to ubound(vdata)
  sdata=sdata & vdata(i,1)
 next l
next reach

Personally, I would prefer the internal copy paste then you could go through each sheet and then grab the data at the very end (this would be pretty fast, faster than looping through each cell). So going through each sheet.

dim wks as worksheet

for each wks in Activeworkbook.Worksheets
 if wks.name <> "CopiedToWorksheet" then
  advancedfilter(...) 'Copy to bottom of list, so you'll need code for that
 end if 
next wks
vdata=activeworkbook.sheets("CopiedToWorksheet").usedrange
sData=vdata(1,1)
for i=lbound(vdata) + 1 to ubound(vdata)
 sData=sData & ","
next i

The above code should be blazing fast. I don't think you can use Join on a variant, but you could always attempt it, that would make it even faster. You could also try application.worksheetfunctions.contat (or whatever the contatenate function is) to combine the results and then just grab the final result.

On Error Resume Next
 wks.ShowAllData
On Error GoTo 0
wks.UsedRange.Rows.Hidden = False
wks.UsedRange.Columns.Hidden = False
rFilterLocation.ClearContents

Upvotes: 1

Related Questions