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

Question

我想运行一个循环来搜索每个单元格(B列(中的单词client，如果任何特定的单元格包含一个client，那么应该复制整行。如果单元格有三次作为客户端，则应粘贴三次行，然后检查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

Answer 1

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

首先，我们使用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, found, str, 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

因此，我们首先循环搜索有多少个点击的单元格，减去一个。减去1，因为我们已经从第一个结果开始，我只想循环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, found 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, found, str, 1) > 0
j = InStr(j, found, str, 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