Question

现在我的宏运行但没有得到所有数字。如果它在＃2上运行一次，则跳过下一个＃2。我怎么能阻止这个。我希望所有人都能得到处理。

实施例
HI（2张）
好的（3张）
再见（2页）

应该是：
HI（2张）
HI（2张）
好的（3张）
好的（3张）
好的（3张）
再见（2张）
再见（2页）

这是我到目前为止所拥有的。

OLD

Sub ExpandRows()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim aCell As Range
Dim i As Integer
Set ws = ThisWorkbook.Sheets("Drawing Index")

With ws
For i = 2 To 99
    Set aCell = .Columns(1).find(What:="(" & i & " SHEETS)", LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
    If Not aCell Is Nothing Then
        aCell.EntireRow.Copy
        aCell.Resize(i - 1).EntireRow.Insert
    End If
    Application.StatusBar = "Duplicating rows containing (" & i & " SHEETS)..."
Next i
End With        
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub

我被告知可能因为insert新行而跳过其他匹配。我怎么能绕过这个？还有另一种方式吗？

EDIT_7.25.17
我试图让这个代码运行，如果一个单元格包含文本＆＃34; SHEETS＆＃34;。我尝试了很多东西而且卡住了。

Sub ExpandRows_if()
Application.ScreenUpdating = False
Dim ws As Worksheet, l As Long, n As Long, s As Long, tmp As String, rng As range, SearchChar As String
Dim LastRow As Long, aCell As range
LastRow = range("A" & Rows.Count).End(xlUp).Row
Set rng = range("A3:A" & LastRow)
Set ws = ThisWorkbook.Sheets("Drawing Index")
SearchChar = "SHEETS"

With ws
For Each aCell In rng.Cells '(x)
    'If aCell.FormulaR1C1 = "=Countifs(rng.value,""*SHEETS)*""),1,0)" > 0 Then '(x)_This works as a formula on the sheet
    If InStr(1, aCell, SearchChar, vbTextCompare) > 0 Then '(x)_Other option i am trying
        For l = .Cells(.Rows.Count, "A").End(xlUp).Row To 1 Step -1
            s = InStr(1, .Cells(l, "A").Value2, "(")
            If CBool(s) Then
                n = val(Mid(.Cells(l, "A").Value2, s + 1))
                If n > 0 Then
                    .Cells(l + 1, "A").Resize(n-1).EntireRow.Insert
                    .Cells(1, "A").Resize(n + 1, 1).EntireRow.FillDown
                    Application.StatusBar = "Duplicating rows containing (" & n & " SHEETS)"
                End If
            End If
        Next l
    Else '(x)
        MsgBox "Damn! Still not working", vbOKOnly, "F*@&" '(x)
    Exit Sub '(x)
    End If '(x)
Next '(x)
End With

Application.ScreenUpdating = True
Application.StatusBar = vbNullString
End Sub

'(x)表示为了使IF语句正常工作而添加的新行。如果没有这些，代码可以工作，但会复制所有行。它应该重复，但.FillDown似乎没有效果。它正在插入正确数量的行。

由于

Answer 1

迭代rng单元格的麻烦在于，当您插入新行时，rng会展开，这会扰乱您的序列。永远不应该迭代受迭代语句影响的集合。

更原始的方法，使用指针变量和条件循环，可以让您重新控制工作表中的位置。

由于我注意到您的样本范围从“A3”单元格开始，我宁愿明确定义一个起始行（在变量FirstRow中，因此您可以参数化您的语句，或者至少在一个整洁的，自我解释的点上编辑它，而不是深入研究代码中更加内在的部分。

至于整洁，我还改变了Dim陈述的方式，以提高可读性。

所以，这应该这样做（它适用于我的测试）：

Sub ExpandRows_if()
    Dim ws As Worksheet
    Dim n As Long
    Dim s As Long
    Dim e As Long
    Dim l As Long
    Dim nl As Long
    Dim tmp As String
    Dim SearchChar As String
    Dim FirstRow As Long
    Dim LastRow As Long
    Dim aCell As Range

    Application.ScreenUpdating = False
    FirstRow = 1
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    Set ws = ThisWorkbook.Sheets("Drawing Index")
    SearchChar = "SHEETS"

    With ws
        l = FirstRow
        Do
            Set aCell = .Cells(l, 1)
            If InStr(1, aCell, SearchChar, vbTextCompare) > 0 And _
               InStr(1, aCell, "(", vbTextCompare) > 0 Then
                s = InStr(1, aCell, "(", vbTextCompare)
                e = InStr(s, aCell, " ", vbTextCompare)
                n = Mid(aCell.Value, s + 1, e - s - 1)
                If n > 1 Then
                    Application.StatusBar = "Duplicating rows containing (" & n & " SHEETS)"
                    For nl = 1 To n - 1
                        aCell.Offset(nl, 0).EntireRow.Insert
                        aCell.Offset(nl, 0).Value = aCell.Value
                        LastRow = LastRow + 1 ' Since a row was inserted, last and
                        l = l + 1             ' current line pointers must increase by 1
                    Next
                End If
            End If
            l = l + 1 ' step to new line
        Loop While l <= LastRow
    End With

    Application.ScreenUpdating = True
    Application.StatusBar = vbNullString
End Sub

搜索单元格的字符串，然后运行宏，如果找到字符串

1 个答案: