在VBA Excel中获取两个字符串之间的内容

Question

我正在编写一个宏，但遇到以下问题：

我有一个标准化的表->请查看附件

由于### START和### END之间的数据可能会发生变化，我想编写一个始终在### START和### END的内容之间查找的宏，并复制动作类型为字词的完整行放入一张新纸上。 由于不熟悉VBA，我不知何故找不到解决方案

有人可以帮忙吗

Answer 1

这应该做。 将以下过程放在标准代码模块中：

Public Sub GetDividends()
    Dim i&, k&, s$, v, r As Range, ws As Worksheet
    Set r = [index(a:a,match("###start",a:a,),):index(a:a,match("###end",a:a,),)].Offset(, 6)
    k = r.Row - 1
    v = r
    For i = 1 To UBound(v)
        If LCase$(v(i, 1)) = "dividend" Then
            s = s & ", " & i + k & ":" & i + k
        End If
    Next
    s = Mid$(s, 3)
    If Len(s) Then
        Set ws = ActiveSheet
        With Sheets.Add(, ws)
            ws.Range(s).Copy .[a1]
        End With
    End If
End Sub

注意：此技术注重效率。 它最大程度地减少了VBA和Excel之间的边界被刺穿的次数。 在大数据集上，这种最佳做法将在性能上产生巨大的差异。

Answer 2

您可以使用find获取行位置，然后从此处设置范围。

Sub Button1_Click()
    Dim r As Range, fr As String    '##START
    Dim c As Range, fc As String    '##END
    Dim StartR As Integer
    Dim EndR As Integer
    Dim NwRng As Range, Nwc As Range
    Dim nwSh As Worksheet
    fr = "##Start"
    fc = "##END"
    Set r = Range("A:A").Find(what:=fr, lookat:=xlWhole)
    Set c = Range("A:A").Find(what:=fc, lookat:=xlWhole)

    If Not r Is Nothing Then
        StartR = r.Row + 1
    Else: MsgBox fr & " not found"
        Exit Sub
    End If

    If Not c Is Nothing Then
        EndR = c.Row - 1
    Else: MsgBox fc & " not found"
        Exit Sub
    End If

    Set NwRng = Range("G" & StartR & ":G" & EndR)
    Set nwSh = Sheets.Add

    For Each Nwc In NwRng.Cells
        If Nwc = "dividend" Then Nwc.EntireRow.Copy nwSh.Cells(nwSh.Rows.Count, "A").End(xlUp).Offset(1)
    Next Nwc

End Sub

Answer 3

如果您的Column Action_Type位于ColumnID 7，则此方法有效。但是我认为源代码很容易更改即可满足您的需要。

Sub copyRows()

Dim i As Integer
Dim ws As Worksheet


'1 is just the worksheet-ID, you can choose another one via name
Set ws = ThisWorkbook.Worksheets(1)


i = 2
j = 1


Do While ws.Cells(i, 1) <> "###END"

'as stated above, 7 refers to the column ID
If ws.Cells(i, 7) = "Dividend" Then


'Worksheets(2), see above

ws.Rows(i).EntireRow.Copy _
        Destination:=Worksheets(2).Rows(j)

j = j + 1

End If

i = i + 1


Loop

End Sub