多行的Excel VBA代码

Question

我有用于附加HTML标记的VBA。 我希望该代码适用于多个行，例如J2：J50000

代码就像

Option Explicit

Sub main()
    Dim newStrng As String
    Dim word As Variant
    Dim parTag As String, endParTag As String
    Dim dateCounter As Long

    parTag = "<p>" '
    endParTag = "</p>" '
    With Worksheets("TextSheet") '
        For Each word In Split(.Range("A1").Text, " ") '<-- Range should be like A1:A50000
            If Len(word) - Len(Replace(word, "/", "")) = 2 Then
                dateCounter = dateCounter + 1
                If dateCounter > 1 Then newStrng = newStrng & endParTag
                newStrng = newStrng & parTag & word
            Else
                newStrng = newStrng & " " & word
            End If
        Next word
        If dateCounter > 1 Then newStrng = newStrng & endParTag
        .Range("A2").Value = LTrim(newStrng)
    End With
End Sub

Answer 1

尝试将范围读入vba数组，然后循环遍历：

Sub main()
    Dim newStrng As String
    Dim word As Variant
    Dim usedCell As Variant
    Dim inputArray() As Variant
    Dim outputArray() As Variant
    Dim parTag As String, endParTag As String
    Dim dateCounter As Long
    Dim i As Long

    parTag = "<p>" '
    endParTag = "</p>" '
    With Worksheets("TextSheet") '
        inputArray = .Range("A1:A50000").Value
        ReDim outputArray(1 To UBound(inputArray, 1))
        For i = 1 To UBound(inputArray, 1)
            dateCounter = 0
            newStrng = ""
            For Each word In Split(inputArray(i, 1), " ")
                If Len(word) - Len(Replace(word, "/", "")) = 2 Then
                    dateCounter = dateCounter + 1
                    If dateCounter > 1 Then newStrng = newStrng & endParTag
                    newStrng = newStrng & parTag & word
                Else
                    newStrng = newStrng & " " & word
                End If
            Next word
            If dateCounter > 1 Then newStrng = newStrng & endParTag
            outputArray(i) = LTrim(newStrng)
        Next i
        .Range("B1:B50000").Value = Application.Transpose(outputArray)
    End With
End Sub

Answer 2

你可以试试这个

Option Explicit

Sub main2()
    Dim newStrng As String
    Dim word As Variant
    Dim usedCell As Variant
    Dim dataArr As Variant
    Dim parTag As String, endParTag As String
    Dim dateCounter As Long
    Dim i As Long

    parTag = "<p>" '
    endParTag = "</p>" '
    With Worksheets("TextSheet") '
        dataArr = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Value
        For i = 1 To UBound(dataArr, 1)
            dateCounter = 0
            newStrng = ""
            For Each word In Split(dataArr(i, 1), " ")
                If Len(word) - Len(Replace(word, "/", "")) = 2 Then
                    dateCounter = dateCounter + 1
                    If dateCounter > 1 Then newStrng = newStrng & endParTag
                    newStrng = newStrng & parTag & word
                Else
                    newStrng = newStrng & " " & word
                End If
            Next word
            If dateCounter > 1 Then newStrng = newStrng & endParTag
            dataArr(i, 1) = LTrim(newStrng)
        Next i
        .Range("B1").Resize(UBound(dataArr, 1)).Value = dataArr
    End With
End Sub