可変テキスト文字列検索列に基づいてX個の行を挿入します。col C

Question

データがある表計算シートがあります。このスクリプトはColデータに対してはうまく動作しますが、col Cを検索する必要があります。文字列のcol cを検索するにはどうすればよいですか？文字列が見つからないか、行が挿入されません。

Option Explicit  
Sub Insert_Rows()  
Dim i As Long, lRows As Long, lastrow As Long, lngCount As Long 
Dim strTxt As String  
Application.ScreenUpdating = False  
lastrow = Cells(Rows.Count, "A").End(xlUp).Row 

lRows = Application.InputBox("How many rows do you want to insert?", Type:=1) 

If lRows < 1 Then 
    MsgBox " You must enter a number greater than zero" 
    Exit Sub 
End If 

strTxt = Application.InputBox("Enter the text string to search on. Rows will be inserted below each cell containing this string.") 

If Len(strTxt) < 1 Then 
    MsgBox "You must enter a text string consisting of at least one character" 
    Exit Sub 
End If 

With ActiveSheet 

    lngCount = Application.WorksheetFunction.CountIf(.Range("A1:A" & lastrow), strTxt) 

    If lngCount < 1 Then 
     MsgBox "The text string you entered is not listed - cancelling", vbExclamation 
     Exit Sub 
    End If 

    On Error Resume Next 

    For i = lastrow To 1 Step -1 
     If .Cells(i, 1).Value = strTxt Then 
      .Range("A" & i + 1 & ":A" & i + lRows).Insert shift:=xlDown 
     End If 
    Next i 

End With  
Application.ScreenUpdating = True   
End Sub 

Answer 1

お客様の直接の問題は、質問のコメントで回答されています。私はこれらの変更を一歩前進させ、ハードコーディングされた列 "A"または "C"を変数に置き換えることになります。その後、任意の列に対してこの関数を使用できます。

Sub Insert_Rows() 
Dim i As Long, lRows As Long, lastrow As Long, lngCount As Long 
Dim col As String, strTxt As String 

Application.ScreenUpdating = False 

col = Application.InputBox("Which column should be inserted into?", Type:=2) 
lastrow = Cells(Rows.Count, col).End(xlUp).Row 

lRows = Application.InputBox("How many rows do you want to insert?", Type:=1) 
If lRows < 1 Then 
    MsgBox " You must enter a number greater than zero" 
    Exit Sub 
End If 

strTxt = Application.InputBox("Enter the text string to search on. Rows will be inserted below each cell containing this string.") 
If Len(strTxt) < 1 Then 
    MsgBox "You must enter a text string consisting of at least one character" 
    Exit Sub 
End If 

With ActiveSheet 
    lngCount = Application.WorksheetFunction.CountIf(.Range(col & "1:" & col & lastrow), strTxt) 

    If lngCount < 1 Then 
     MsgBox "The text string you entered is not listed - cancelling", vbExclamation 
     Exit Sub 
    End If 

    On Error Resume Next 

    For i = lastrow To 1 Step -1 
     If .Cells(i, col).Value = strTxt Then 
      .Range(col & i + 1 & ":" & col & i + lRows).Insert shift:=xlDown 
     End If 
    Next i 
End With 

Application.ScreenUpdating = True 
End Sub