数组拆分和提取vba excel [英] Array split and extract vba excel

问题描述

我得到了这个代码的帮助，但运行它不会执行它需要做的事情。我试图从第一张表的第C行中提取带有下划线和斜体的单词，并将其移动到秒表。预期的结果是在第二个图像。阵列拆分在这种情况下会有用吗？希望样本数据更加清晰。

  Sub proj（）
 
 
对于每个cl范围（C1：C5）
调用CopyItalicUnderlined（cl，Worksheets（Sheet2）。Range（A1））
下一个
 
 End Sub 
 
 Sub CopyItalicUnderlined（rngToCopy，rngToPaste）
 
 rngToCopy.Copy rngToPaste 
 
 Dim i 
对于i = Len（rngToCopy .Value2）到1步-1 
用rngToPaste.Characters（i，1）
如果没有.Font.Italic而不是.Font.Underline然后
 .Text = vbNullString 
结束如果
结束
下一个
 
 
结束Sub 
  

< DIV class =h2_lin>解决方案

Split（）可以帮助，但只有在您已经找到并解析斜体字之后， c> Characters（）方法可以在范围对象调用

你可以然后尝试以下代码：

  Option Explicit 
 
 Sub proj（）
 Dim dataRng作为范围，cl作为范围
 Dim arr As Variant 
 
设置dataRng =工作表（ItalicSourceSheet）。range（C1：C5）'<  -  |更改ItalicSourceSheet与您的实际源表单名称
与工作表（ItalicOutputSheet）'<  -  |更改ItalicOutputSheet与您的实际输出表名称
对于每个cl在dataRng 
 arr = GetItalics（cl）'<  -  |使用斜体字获取数组
 If IsArray（arr）Then .Cells（.Rows.Count，1）.End（xlUp）.Offset（1）.Resize（UBound（arr）+ 1）= Application.Transpose arr）'<  -  |如果数组被填充，然后将其写入列A中的输出表第一个空白单元
下一个
结束
 End Sub 
 
函数GetItalics（rng As range ）As Variant 
 Dim strng As String 
 Dim iEnd As Long，iIni As Long，strngLen As Long 
 
 strngLen = Len（rng.Value2）
 iIni = 1 
尽管iEnd< = strngLen 
尽管rng.Characters（iEnd，1）.Font.Italic和rng.Characters（iEnd，1）.Font.Underline 
如果iEnd = strngLen然后退出Do 
 iEnd = iEnd + 1 
循环
如果iEnd> iIni然后strng = strng& Mid（rng.Value2，iIni，iEnd  -  iIni）& | 
 iEnd = iEnd + 1 
 iIni = iEnd 
循环
如果strng<> 然后GetItalics = Split（Left（strng，Len（strng） -  1），|）
结束函数
  

I got help with this code but when it runs it does not execute what it needs to do. I'm trying to extract words that are underlined and italicized from row C of the first sheet and move them to the secondsheet. The expected outcome is in the second image. Would array splitting be of use in this situation? Hopefully the sample data make it more clear.

Sub proj()


For Each cl In Range("C1:C5")
        Call CopyItalicUnderlined(cl, Worksheets("Sheet2").Range("A1"))
    Next

End Sub

Sub CopyItalicUnderlined(rngToCopy, rngToPaste)

rngToCopy.Copy rngToPaste

Dim i
For i = Len(rngToCopy.Value2) To 1 Step -1
    With rngToPaste.Characters(i, 1)
        If Not .Font.Italic And Not .Font.Underline Then
            .Text = vbNullString
        End If
    End With
Next


End Sub

解决方案

Split() could help, but only after you already found out and parsed italic words since Characters() method can be called on Range object only

you could then try the following code:

Option Explicit

Sub proj()
    Dim dataRng As range, cl As range
    Dim arr As Variant

    Set dataRng = Worksheets("ItalicSourceSheet").range("C1:C5") '<--| change "ItalicSourceSheet" with your actual source sheet name
    With Worksheets("ItalicOutputSheet") '<--|change "ItalicOutputSheet" with your actual output sheet name
        For Each cl In dataRng
            arr = GetItalics(cl) '<--| get array with italic words
            If IsArray(arr) Then .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr) + 1) = Application.Transpose(arr) '<--| if array is filled then write it down to output sheet first blank cell in column "A"
        Next
    End With
End Sub

Function GetItalics(rng As range) As Variant
    Dim strng As String
    Dim iEnd As Long, iIni As Long, strngLen As Long

    strngLen = Len(rng.Value2)
    iIni = 1
    Do While iEnd <= strngLen
        Do While rng.Characters(iEnd, 1).Font.Italic And rng.Characters(iEnd, 1).Font.Underline
            If iEnd = strngLen Then Exit Do
            iEnd = iEnd + 1
        Loop
        If iEnd > iIni Then strng = strng & Mid(rng.Value2, iIni, iEnd - iIni) & "|"
        iEnd = iEnd + 1
        iIni = iEnd
    Loop
    If strng <> "" Then GetItalics = Split(Left(strng, Len(strng) - 1), "|")
End Function

这篇关于数组拆分和提取vba excel的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！