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.

thanks.
EE.xlsm
Screen-Recorded.mp4
LVL 6
FloraAsked:
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)
    Next
    Set ws = Nothing
    Set wb = Nothing
Exit Sub
Error:
    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"
    firstRange.Clear
    secondRange.Clear
    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)
            Else
                d = -1 + f(y, x)
                u = GAP + f(y, j)
                l = GAP + f(i, x)
            End If
            f(i, j) = Max(d, u, l)
        Next
    Next
    
    i = UBound(f, 1): j = UBound(f, 2)
    On Error Resume Next
    Do
        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)
diag:
                a_ = Mid$(a, j, 1) & a_
                b_ = Mid$(b, i, 1) & b_
                i = i - 1: j = j - 1
            Case u > l
up:
                a_ = PAD & a_
                b_ = Mid$(b, i, 1) & b_
                i = i - 1
            Case l > u
left:
                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:
Error:
    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
    Next
    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
    Next

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
            Do
                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
                        Else
                            i = c + k
                            Exit Do
                        End If
                    Else
                        i = c + k
                        Exit Do
                    End If
                End If
                If c + k > Len(s1) Then Exit Do
            Loop
        Else
            Exit For
        End If
    Next
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.
0
 
FloraAuthor Commented:
Fabrice

You are genius!

thanks a million.
0
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.