Loop A Script

[grayghost]

Hi guys,

The script below compares the contents of A1 to B1 and then places the unique content of B1 into cell C1. Is there a way to make it plural, where it will loop down to A2:B2 -> C2 and so on? I have about 4,000 rows to work with. Thank you so much for your suggestions!


[VBA]Sub MG23Jan24()
Dim Ray1, Ray2, Txt As String
Dim R1 As Integer
Dim R2 As Integer
Dim Fd As Boolean
Ray1 = Split([A1], ",")
Ray2 = Split([B1], ",")

For R2 = 0 To UBound(Ray2)
Fd = False
For R1 = 0 To UBound(Ray1)
If Trim(Ray2(R2)) = Trim(Ray1(R1)) Then
Fd = True
Exit For
End If
Next R1
If Fd = False Then
Txt = Txt & Ray2(R2) & ","
End If
Next R2
If Not Txt = vbNullString Then
Range("C1") = Left(Txt, Len(Txt) - 1)
End If
End Sub[/VBA]

[p45cal]

try (changes in red):
[vba]Sub MG23Jan24()
Dim Ray1, Ray2, Txt As String
Dim R1 As Long
Dim R2 As Long
Dim Fd As Boolean
Dim LR As Long
LR = Cells(Rows.Count, 1).End(xlUp).Row
For Each cll In Range("A1:A" & LR).Cells
Ray1 = Split(cll, ",")
Ray2 = Split(cll.Offset(, 1), ",")

For R2 = 0 To UBound(Ray2)
Fd = False
For R1 = 0 To UBound(Ray1)
If Trim(Ray2(R2)) = Trim(Ray1(R1)) Then
Fd = True
Exit For
End If
Next R1
If Fd = False Then
Txt = Txt & Ray2(R2) & ","
End If
Next R2
If Not Txt = vbNullString Then
cll.Offset(, 2) = Left(Txt, Len(Txt) - 1)
Txt = Empty 'not sure if you want this line in.
End If
Next cll
End Sub
[/vba]

[stanleydgrom]

grayghost,

Welcome to the vbaexpress forum.


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).


[VBA]

Option Explicit
Sub MG23Jan24()

' stanleydgrom, 04/01/2011
' http://www.vbaexpress.com/forum/showthread.php?t=36848

Dim Ray1, Ray2, Txt As String
Dim R1 As Long, R2 As Long

'LR = LastRow used row in column A
'a is a Loop counter from row 1 to the LastRow in column A

Dim LR As Long, a As Long

Dim Fd As Boolean

'Turn off screen flicker/updating. Code will execute faster.
Application.ScreenUpdating = False

LR = Cells(Rows.Count, "A").End(xlUp).Row
For a = 1 To LR Step 1
Ray1 = Split(Cells(a, 1), ",")
Ray2 = Split(Cells(1, 2), ",")
For R2 = 0 To UBound(Ray2)
Fd = False
For R1 = 0 To UBound(Ray1)
If Trim(Ray2(R2)) = Trim(Ray1(R1)) Then
Fd = True
Exit For
End If
Next R1
If Fd = False Then
Txt = Txt & Ray2(R2) & ","
End If
Next R2
If Not Txt = vbNullString Then
Range("C" & a) = Left(Txt, Len(Txt) - 1)
End If
Next a

'Turn on screen flicker/updating.
Application.ScreenUpdating = True
End Sub

[/VBA]


Then run the MG23Jan24 macro.


If the above macro does not work correct then please post your workbook.

To attach your workbook, scroll down and click on the Go Advanced button, then scroll down and click on the Manage Attachments button.


Have a great day,
Stan

[grayghost]

p45cal - Thank you immensely! Your changes worked perfectly. As a note to future viewers, make sure all the words are delimited by commas.