查找并复制整行并在当前行下方插入复制的行

如何解决查找并复制整行并在当前行下方插入复制的行

我想运行一个循环来搜索每个单元格（B 列）中的单词 client，如果任何特定单元格包含客户端，则应复制整行。如果单元格有 3 次作为客户端，则应粘贴 3 次行，然后检查 B 列的下一个单元格。

Dim chk As String
Dim Rng As Range
chk = ThisWorkbook.Sheets("clt").Range("A1").Value
LR = Range("B" & Rows.Count).End(xlUp).Row
Range("B1").Select
Set Rng = Range("B1:B" & LR)
For Each cell In Rng
If InStr(LCase(cell.Value),LCase(chk)) <> 0 Then
Cells.Find(what:="Client",After:=ActiveCell,LookIn:=xlFormulas2,_
        LookAt:=xlPart,SearchOrder:=xlByRows,SearchDirection:=xlNext,_
        MatchCase:=False,SearchFormat:=False).Activate
        
       
ActiveCell.Offset(1,0).Select
   
ActiveCell.EntireRow.copy
ActiveCell.Offset(1,-1).Select
Selection.Insert Shift:=xlDown
    End If
Next cell

解决方法

所以我们需要做一些事情。 与往常一样，可能有捷径，但我发现的一种方法是：

首先，我们使用 WorksheetFunction.CountIf 检查有多少行包含我们要查找的单词。
然后搜索列，得到第一个单元格。
从这里开始，我们对每次出现使用 FindNext 一次，并使用 InStr

计算该单词在单元格中出现的次数

Sub searchCopy()
Dim sRng As Range,found As Range,count As Long
Dim i as Long,j as long,k as long
Dim str As String

Set sRng = ActiveSheet.Range("B:B")
str = "client" ' this supposed to be - ThisWorkbook.Sheets("clt").Range("A1").Value - maybe?

count = Application.WorksheetFunction.CountIf(sRng,"*" & str & "*")
Set found = sRng.Find(str)
For i = 0 To count - 1
    j = 1
    k = 0
    While InStr(j,found,str,1) > 0
        j = InStr(j,1) + 1
        k = k + 1
    Wend
    If k > 1 Then
        found.EntireRow.Copy
        found.EntireRow.Resize(k - 1).Insert Shift:=xlDown
    End If
    Set found = sRng.FindNext(found)
Next i
End Sub

  

因此，我们首先循环搜索与点击次数一样多的单元格，减去一。减去一个，因为我们已经从第一个结果开始，我只想循环 FindNext。
我的“整数”i、j 和 k 分别是循环计数、字符串位置和字数。
所以我们从字符串的第一个字符开始搜索，我们从找到的 0 个单词开始。
Instr 返回我们搜索第一次出现的位置，如果没有则返回 0。
获得匹配后，我们将该位置添加到我们的字符串位置变量中，并加一。并在字数上加一。
然后在这个位置开始新的搜索。这将跳过之前找到的单词，并检查是否还有其他单词。

计数完成后，我们在当前位置插入新行，因此“在”当前行之前。 FindNext 这次不会找到这些行。

这是一个没有 While 循环计数的版本，而是使用替换方法：

Sub searchCopy()
Dim sRng As Range,found As Range
Dim count As Long,i As Long,j As Long
Dim str As String

Set sRng = ActiveSheet.Range("B:B")
str = "client" 

count = WorksheetFunction.CountIf(sRng,"*" & str & "*")
Set found = sRng.Find(str)
For i = 0 To count - 1
    j = (Len(found) - Len(Replace(UCase(found),UCase(str),""))) / Len(str)
    If j > 1 Then
        found.EntireRow.Copy
        found.EntireRow.Resize(j - 1).Insert Shift:=xlDown
    End If
    Set found = sRng.FindNext(found)
Next i
End Sub

请记住，这不会检查之前是否已完成此操作。所以如果你再次运行它，你最终会得到一堆额外的行。

新问题

如果我们想把找到的行拆分成不同的行，每个客户端一个，我们必须做一些调整。
在第一个示例中，我们已经在跟踪有关不同客户端的文本的开始位置，因此让我们保存此信息。
现在有一百种不同的方法来解决这个问题，但为什么不使用集合。
我们标记匹配字符串的每个“开始”，然后照常进行。
插入行后——现在是空白——我们可以向它们添加信息。
现在有一些数学计算，但我们需要跟踪将信息放入哪个单元格，以及我们需要复制字符串的哪个部分。
我正在使用 Mid 函数从原始字符串中提取剪切字符串。

注意 这将删除第一个匹配项之前出现的字符串的任何部分。

Sub searchSplit()
Dim sRng As Range,count As Long
Dim i As Long,j As Long
Dim str As String
Dim coll As Collection

Set sRng = ActiveSheet.Range("B:B")
str = "client" 

count = Application.WorksheetFunction.CountIf(sRng,"*" & str & "*")
Set found = sRng.Find(str)
For i = 0 To count - 1
    Set coll = New Collection
    j = 1
    While InStr(j,1) + 1
        coll.Add j - 1
    Wend
    coll.Add Len(found)
    If coll.count > 2 Then
        found.EntireRow.Resize(coll.count - 2).Insert Shift:=xlDown
        For j = 1 To coll.count - 1
            found.Offset(j - (coll.count - 1)).Value = Mid(found,coll(j),coll(j + 1) - coll(j))
        Next j
    End If
    Set found = sRng.FindNext(found)
Next i
End Sub