Help needed for macro to loop through cells instead of manually doing one by one.

Please see attached video a SCREEN-RECORDED.MP4, it shows clearly my struggle.

I have also attached the workbook.

i need help with macro to be modified so that instead of this copy paste into the helper sheet1 and then getting result back to sheet2

i simply run the macro once and it will loop through sheet2 column A and B and then populate the result in C and D.

i tried for two hours, i could not decipher the decipher the code to make it work.

any help is appreciated.

Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Fabrice LambertFabrice LambertCommented:
In short:

First, give you procedure AlignStrings 4 parameters: first text, 2nd text, 1st range result and 4th range result.
Second, make an additional procedure that will loop trough your range in sheet2, and call the AlignStrings procedure with the required parameters.
Third, call the newly created procedure from the button.

plus some additional changes, I kept your old code in comments:
Option Explicit

Public Sub AlignAllString()
On Error GoTo Error
    Dim wb As Excel.Workbook
    Dim ws As Excel.Worksheet
    Dim rng As Excel.Range
    Dim i As Long
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets(2)
        '// may need something better than used range to detect the last row
    For i = 1 To ws.UsedRange.Rows.Count
        AlignStrings ws.Cells(i, 1), ws.Cells(i, 2), ws.Cells(i, 3), ws.Cells(i, 4)
    Set ws = Nothing
    Set wb = Nothing
Exit Sub
    If Not (ws Is Nothing) Then
        Set ws = Nothing
    End If
    If Not (wb Is Nothing) Then
        Set wb = Nothing
    End If
    MsgBox Err.Description, vbOKOnly + vbCritical, "Error"
End Sub

Private Sub AlignStrings(ByRef firstText As Excel.Range, ByRef secondText As Excel.Range, ByRef firstRange As Excel.Range, ByRef secondRange As Excel.Range)
On Error GoTo Error
    'Needleman–Wunsch algorithm

    Dim a() As Byte, b() As Byte, a_$, b_$, i&, j&, d&, u&, l&, x&, y&, f&()
    Const GAP = -1
    Const PAD = "_"
    '// a = [a1].Text: b = [a2].Text
    a = firstText.Text
    b = secondText.Text
'    [a3:a6].Clear
'    [a1:a6].Font.Name = "Courier New"
    firstText.Font.Name = "Courier New"
    secondText.Font.Name = "Courier New"
    firstRange.Font.Name = "Courier New"
    secondRange.Font.Name = "Courier New"
    ReDim f(0 To UBound(b) \ 2 + 1, 0 To UBound(a) \ 2 + 1)
    For i = 1 To UBound(f, 1)
        For j = 1 To UBound(f, 2)
            x = j - 1: y = i - 1
            If a(x * 2) = b(y * 2) Then
                d = 1 + f(y, x)
                u = 0 + f(y, j)
                l = 0 + f(i, x)
                d = -1 + f(y, x)
                u = GAP + f(y, j)
                l = GAP + f(i, x)
            End If
            f(i, j) = Max(d, u, l)
    i = UBound(f, 1): j = UBound(f, 2)
    On Error Resume Next
        x = j - 1: y = i - 1
        d = f(y, x)
        u = f(y, j)
        l = f(i, x)
        Select Case True
            Case Err
                If y < 0 Then GoTo left Else GoTo up
            Case d >= u And d >= l Or Mid$(a, j, 1) = Mid$(b, i, 1)
                a_ = Mid$(a, j, 1) & a_
                b_ = Mid$(b, i, 1) & b_
                i = i - 1: j = j - 1
            Case u > l
                a_ = PAD & a_
                b_ = Mid$(b, i, 1) & b_
                i = i - 1
            Case l > u
                a_ = Mid$(a, j, 1) & a_
                b_ = PAD & b_
                j = j - 1
        End Select
    Loop Until i < 1 And j < 1
    '// DecorateStrings a_, b_, [a5], [a6], PAD
    DecorateStrings a_, b_, firstRange, secondRange, PAD
Exit Sub:
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub

Private Function Max(a&, b&, c&) As Long
    Max = a
    If b > a Then Max = b
    If c > b Then Max = c
End Function

Private Sub DecorateStrings(a$, b$, rOutA As Range, rOutB As Range, PAD$)
    Dim i&, j&

    FloatArtifacts a, b, PAD
    FloatArtifacts b, a, PAD
    rOutA = a
    rOutB = b
    For i = 1 To Len(a)
        If Mid$(a, i, 1) <> Mid$(b, i, 1) Then
            If Mid$(a, i, 1) <> PAD Then
                rOutA.Characters(i, 1).Font.Color = vbRed
            End If
        End If
    For i = 1 To Len(b)
        If Mid$(a, i, 1) <> Mid$(b, i, 1) Then
            If Mid$(b, i, 1) <> PAD Then
                rOutB.Characters(i, 1).Font.Color = vbRed
            End If
        End If

End Sub

Private Sub FloatArtifacts(s1$, s2$, PAD$)
    Dim c&, k&, i&, p&
    For i = 1 To Len(s1)
        c = InStr(i, s1, PAD)
        If c Then
            k = 0
                k = k + 1
                If Mid$(s1, c + k, 1) <> PAD Then
                    If Mid$(s2, c, 1) = Mid$(s1, c + k, 1) Then
                        p = InStr(c + k, s1, PAD)
                        If p < (c + k + 6) And p > 0 Then
                            Mid$(s1, c, 1) = Mid$(s1, c + k, 1)
                            Mid$(s1, c + k, 1) = PAD
                            i = c
                            Exit Do
                            i = c + k
                            Exit Do
                        End If
                        i = c + k
                        Exit Do
                    End If
                End If
                If c + k > Len(s1) Then Exit Do
            Exit For
        End If
End Sub

Open in new window

PS: I don't know who wrote the code in this workbook, but there is a urge for him to learn good practices:
- Fully and clearly qualify variables.
- Use meaningfull variables names.
- Write error handlers when necessary.

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
FloraAuthor Commented:

You are genius!

thanks a million.
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today

From novice to tech pro — start learning today.