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?
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.
FloraAuthor Commented:

You are genius!

thanks a million.
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.