kapriano
11-07-2017, 04:21 AM
20874
{up.persianscript.ir/uploads2/ad51-Book1.rar}
Hi
I'm doing my job using the code below
I want to open a window asking me the following variable
"Set c = .Find("t.me/canx1/", LookIn:=xlValues)"
I also enter the new or desired variable
Can friendship help?
thanks
Sub Demo()
Dim dataRng As Range
Dim foundCell As Range
Dim ary() As String
On Error Resume Next
' remove empty cells in column A
ActiveSheet.Range("A:A").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
' group cells by "t.me/canx1/" and add name for each group
Set dataRng = ActiveSheet.Range("A:A") 'column A
With dataRng
Set c = .Find("t.me/canx1/", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Set c = .FindNext(c)
ReDim Preserve ary(i)
ary(i) = c.Row
i = i + 1
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
First = LBound(ary)
Last = UBound(ary)
For i = First To Last - 1
For j = i + 1 To Last
If ary(i) - ary(j) > 0 Then
Temp = ary(j)
ary(j) = ary(i)
ary(i) = Temp
End If
Next j
Next i
Dim xName As Name
For Each xName In Application.ActiveWorkbook.Names
xName.Delete
Next
For i = 0 To UBound(ary) - 1
ActiveWorkbook.Names.Add Name:="Group" & i + 1, RefersTo:=Range(Range("A" & ary(i)), Range("A" & ary(i + 1) - 1))
Next
ActiveWorkbook.Names.Add Name:="Group" & UBound(ary) + 1, RefersTo:=Range(Range("A" & ary(UBound(ary))), dataRng.End(xlDown))
' search which group contains keyword and delete the named range
With dataRng
For Each cell In Range("C1", Range("C:C").End(xlDown)) ' C1 to last cell
Set c = .Find(cell.Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Set c = .FindNext(c)
For Each xName In Application.ActiveWorkbook.Names
If Not Intersect(c, Range(xName)) Is Nothing Then
If rng Is Nothing Then
Set rng = Range(xName)
Else
Set rng = bigRange
End If
Set bigRange = Application.Union(Range(xName), rng)
xName.Delete
End If
Next
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Next
End With
bigRange.Delete
If Error.Count > 0 Then
Error.Clear
End If
End Sub
{up.persianscript.ir/uploads2/ad51-Book1.rar}
Hi
I'm doing my job using the code below
I want to open a window asking me the following variable
"Set c = .Find("t.me/canx1/", LookIn:=xlValues)"
I also enter the new or desired variable
Can friendship help?
thanks
Sub Demo()
Dim dataRng As Range
Dim foundCell As Range
Dim ary() As String
On Error Resume Next
' remove empty cells in column A
ActiveSheet.Range("A:A").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
' group cells by "t.me/canx1/" and add name for each group
Set dataRng = ActiveSheet.Range("A:A") 'column A
With dataRng
Set c = .Find("t.me/canx1/", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Set c = .FindNext(c)
ReDim Preserve ary(i)
ary(i) = c.Row
i = i + 1
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
First = LBound(ary)
Last = UBound(ary)
For i = First To Last - 1
For j = i + 1 To Last
If ary(i) - ary(j) > 0 Then
Temp = ary(j)
ary(j) = ary(i)
ary(i) = Temp
End If
Next j
Next i
Dim xName As Name
For Each xName In Application.ActiveWorkbook.Names
xName.Delete
Next
For i = 0 To UBound(ary) - 1
ActiveWorkbook.Names.Add Name:="Group" & i + 1, RefersTo:=Range(Range("A" & ary(i)), Range("A" & ary(i + 1) - 1))
Next
ActiveWorkbook.Names.Add Name:="Group" & UBound(ary) + 1, RefersTo:=Range(Range("A" & ary(UBound(ary))), dataRng.End(xlDown))
' search which group contains keyword and delete the named range
With dataRng
For Each cell In Range("C1", Range("C:C").End(xlDown)) ' C1 to last cell
Set c = .Find(cell.Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Set c = .FindNext(c)
For Each xName In Application.ActiveWorkbook.Names
If Not Intersect(c, Range(xName)) Is Nothing Then
If rng Is Nothing Then
Set rng = Range(xName)
Else
Set rng = bigRange
End If
Set bigRange = Application.Union(Range(xName), rng)
xName.Delete
End If
Next
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Next
End With
bigRange.Delete
If Error.Count > 0 Then
Error.Clear
End If
End Sub