New column through existing ones

[Anfan]

Hello Every one,
I have a list having seven columns A,B,C,D,E,F,G where the column E is now empty and its supposed to be filled with members of column G thruogh a criteria. Now important for my problem are only the columns A,D,E and F,G.

How it is now:
A.........B..C......D............E...............F...........G

m1.......x..x..... a;b;c.......?..............b...........a;c;d;e;f

m2.......x..x......c;d;e;f.....?..............c...........d;f;n;g
m3.......x..x......f;g..........?..............d...........y;z



How it is supposed to look like: (only Column E must be filled!)

A.........B..C......D............E.............................F........... G

m1.......x..x..... a;b;c.......a;c;d;e;f;n;g..............b...........a;c;d;e;f

m2.......x..x......c;d;e;f.....d;f;n;g;y;z.................c...........d;f; n;g
m3.......x..x......f;g..........?.............................d...........y ;z

I need a macro which should read the members of column D and search for each of them in whole column F. If a member of D equals the string in F, then the corresponding G members should be copied and pasted into column E. No duplicates in Column E should be allowed.

Its my first post here. I hope that i could describe my problem properly.

Thanks

Excel file containing the upper example:

[Bob Phillips]

Blimey, that was tricky



Public Sub ProcessData()
Dim i As Long, j As Long, k As Long, l As Long
Dim LastRow As Long
Dim aryTemp As Variant, aryLook As Variant, aryResults As Variant
Dim Formula1 As String, Formula2 As String
Dim TestValue As String

With ActiveSheet

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Formula1 = "IF(ISNUMBER(MATCH(F1:F4,"
Formula2 = ",0)),G1:G4,-99)"
For i = 1 To LastRow

If .Cells(i, "D").Value <> "" Then

aryTemp = Split(.Cells(i, "D").Value, ";")
TestValue = "{""" & Replace(Join(aryTemp, ","), ",", """,""") & """}"
aryLook = Application.Transpose(.Evaluate(Formula1 & TestValue & Formula2))
ReDim aryResults(1 To 1000)
k = 0
For j = LBound(aryLook) To UBound(aryLook)

If aryLook(j) <> -99 Then

aryTemp = Split(aryLook(j), ";")
For l = LBound(aryTemp) To UBound(aryTemp)

If IsError(Application.Match(aryTemp(l), aryResults, 0)) Then

k = k + 1
If k > UBound(aryResults) Then

ReDim Preserve aryResults(1 To UBound(aryResults) + 1000)
End If
aryResults(k) = aryTemp(l)
End If
Next l
End If
Next j

If k > 0 Then

ReDim Preserve aryResults(1 To k)
.Cells(i, "E").Value = Join(aryResults, ";")
End If
End If
Next i
End With
End Sub

[Anfan]

Thank you very much! but unfortuantely its not working for bigger list. The three lines were only an example. In the reality there are over 150 000 Lines!! :-) The current code only words for the first 4 line. Hope that the problem is solvable

[Bob Phillips]

Post your workbook, I cannot read tea-leav es.

[Anfan]

Dear xld,
thank you very much for your help. The problem is not yet solved. I had to change remove the limitaion from 4 to the needed number:


Formula1 = "IF(ISNUMBER(MATCH(F1:F4,"
Formula2 = ",0)),G1:G4,-99)"



Formula1 = "IF(ISNUMBER(MATCH(F1:F150000,"
Formula2 = ",0)),G1:G150000,-99)"


but its not working

Regards

[Anfan]

Hello XLD,

i thought it was working but it doesnt. :-( Unfortunately i can upload any file here. Dont know why. May be cus i am new here.

I have uploaded the example file to another place. Please download it under following link:

www&qamosoona.com$download$NewEb.rar ( please replace & to . and $ to /)

I am uploading only a part of the file cus of the copy right matters. The whole list contain of over 150t words.

thank you very much.

[Bob Phillips]

I cannot read arabic, so there is no way I can test that.

[Anfan]

Ok,

here is another file containing roman letters and numbers. You can controll the macro with it.

www$qamosoona.com?download?E.rar ( Excel 2007 file xlsx)

The last cells of column G ( G150000) are aaa, bbb, ccc, ddd,.... The problem will be solved if the macro reaches upto here.

thanks

[Bob Phillips]

I think there is just too much data to store in an array.

I guess you are out of luck on this one.