Deleting rows with 11+ characters.

[Sinner]

I have the following code for deleting pins found in a list in
"column
1" of "sheet1" from list in "column 1" of "sheet 2" with the list
tagged in other columns, leaving behind updated & reconciled dataset
in sheet 2.

Format of "sheet 1" is like:


1100000086125125778
1100000086125125779
1100000086125125782


Format of "sheet 2" is like:


1100000086125125778 KANSAS NORTH
MARKED 441
1100000086125125779 KANSAS NORTH
MARKED 443
1100000086125125780 PARIS CENTRAL
MARKED 442
1100000086125125781 KOREA SOUTH
MARKED 441
1100000086125125782 NEPAL NORTH-II
MARKED 441


The updated record set after the script is run should be like:


1100000086125125780 PARIS CENTRAL
MARKED 442
1100000086125125781 KOREA SOUTH
MARKED 441


which I can carry forward for next term.


The pins however are more than 11 characters long i.e. 19 to 20
characters. e.g. 1100000086125125778, 1100000086125125779,
1100000086125125780 and so on.


First 8 to 9 are common characters in the list so I trim them to 11
to
make my lists for further processing. After I have the updated
dataset
of the list, I add the common starting characters back.


Any suggestions?


Secondly, I would like the script to auto sort the lists in both the
sheets in ascending order before deletion BUT as there are multiple
columns in "sheet 2" with tags in other columns, we need to sort that
sheet so that it does not disturb the column order in the adjacent
column (like sort option from autofilter where the column/row data
integrity is not compromised).


CODE is as follows:
---------------------------------------------------------------------------­-----------------------
---------------------------------------------------------------------------­-----------------------


Dim rngeSht1 As Range
Dim rngeSht2 As Range
Dim PinNumber
Dim Serial
Dim NameToFind
Dim Y


Sub Delete_Rows()


Sheets("Sheet1").Select
'Insert a column to left of data on sheet 1
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Range("A1").Select


'Set this to a range as column 1 and to include all rows
Set rngeSht1 = Worksheets("Sheet1").Range("A1", Cells(Rows.Count,
1))


'Each value trimmed of superflourous leading and trailing spaces
For Each Serial In rngeSht1
PinNumber = Trim(Serial.Offset(0, 1).Range("A1"))
Serial.Value = PinNumber
If Serial.Value = "" Then
Exit For 'Exit when run out of data
End If
Next Serial


Sheets("Sheet2").Select


'Insert a column to left of data on sheet 2
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Range("A1").Select


'Set this to a range as column 1 and to include all rows
Set rngeSht2 = Worksheets("Sheet2").Range("A1", Cells(Rows.Count,
1))


'Concatonate all the values in cells and place in one cell
'Each value trimmed of superflourous leading and trailing spaces
For Each Serial In rngeSht2
PinNumber = Trim(Serial.Offset(0, 1).Range("A1"))
Serial.Value = PinNumber


If Serial.Value = "" Then
Exit For 'Exit when run out of data
End If
Next Serial


'For each value in sheet 1, find corresponding value
'in sheet 2 and if found, delete entirerow.
For Each Serial In rngeSht1
If Serial.Value = "" Then
Exit For 'Exit when run out of data to find
End If


NameToFind = Serial.Value
Set Y = rngeSht2.Find(What:=NameToFind, _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns
_
, SearchDirection:=xlNext, MatchCase:=False,
SearchFormat:=False)


If Not Y Is Nothing Then 'Y Not Nothing = Found target
Do
Y.EntireRow.Delete


'NOTE: FindNext does not work when a row from the
range
'has been deleted. Must repeat full find method


Set Y = rngeSht2.Find(What:=NameToFind, _
LookIn:=xlFormulas, LookAt:=xlWhole,
SearchOrder:=xlByColumns _
, SearchDirection:=xlNext, MatchCase:=False,
SearchFormat:=False)
Loop While Not Y Is Nothing
End If


Next Serial
Sheets("Sheet1").Select
Columns("A:A").Delete
Range("A1").Select
Sheets("Sheet2").Select
Columns("A:A").Delete
Range("A1").Select


End Sub
---------------------------------------------------------------------------­-----------------------
---------------------------------------------------------------------------­-----------------------

 

[Guest]

Not sure why you need to split the keys into 8 or 9 charaters. Possibly they
need to be declared as double or may want to treat them as character instead
of number. code below will sort a block data where the data may be on more
than one row.


Sub Sortblock()

Const BlockRows = 3
Const StartRow = 2
SortColumn = 1

LastRow = Cells(Rows.Count, 1).End(xlUp).Row
LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column

For i = StartRow To (LastRow - BlockRows) Step BlockRows
For j = (StartRow + BlockRows) To LastRow Step BlockRows

If Cells(i, SortColumn) > Cells(j, SortColumn) Then

Set CutRange = Range(Cells(j, 1), _
Cells(j + BlockRows - 1, 1)).EntireRow

CutRange.Cut
Range("A" & i).Insert Shift:=xlDown

End If

Next j
Next i

End Sub

 

[JE McGimpsey]

One way:

No need to trim that I can see.

Dim vArr As Variant
Dim rCell As Range
Dim rDelete As Range
Dim nLow As Long
Dim nHigh As Long
Dim i As Long
Dim sTest As String

With Sheets("Sheet1")
vArr = .Range(.Cells(1, 1), _
.Cells(.Rows.Count, 1).End(xlUp)).Value
End With
nLow = LBound(vArr, 1)
nHigh = UBound(vArr, 1)
With Sheets("Sheet2")
For Each rCell In .Range(.Cells(1, 1), _
.Cells(.Rows.Count, 1).End(xlUp))
sTest = rCell.Text
For i = nLow To nHigh
If sTest = vArr(i, 1) Then
If rDelete Is Nothing Then
Set rDelete = rCell
Else
Set rDelete = Union(rDelete, rCell)
End If
End If
Next i
Next rCell
If Not rDelete Is Nothing Then rDelete.EntireRow.Delete
End With

 

[Sinner]

One way:

No need to trim that I can see.

Dim vArr As Variant
Dim rCell As Range
Dim rDelete As Range
Dim nLow As Long
Dim nHigh As Long
Dim i As Long
Dim sTest As String

With Sheets("Sheet1")
vArr = .Range(.Cells(1, 1), _
.Cells(.Rows.Count, 1).End(xlUp)).Value
End With
nLow = LBound(vArr, 1)
nHigh = UBound(vArr, 1)
With Sheets("Sheet2")
For Each rCell In .Range(.Cells(1, 1), _
.Cells(.Rows.Count, 1).End(xlUp))
sTest = rCell.Text
For i = nLow To nHigh
If sTest = vArr(i, 1) Then
If rDelete Is Nothing Then
Set rDelete = rCell
Else
Set rDelete = Union(rDelete, rCell)
End If
End If
Next i
Next rCell
If Not rDelete Is Nothing Then rDelete.EntireRow.Delete
End With



- Show quoted text -

Dear Joel & JE McGimpsey,

Thank you for your replies.

JE McGimpsey I want to reuse the same sheet with another set of data.
I have added

Sub Clear()

Sheets(Array("Sheet1", "Sheet2")).Select
Sheets("Sheet1").Activate
Cells.Select
Selection.Clear
Sheets("Sheet2").Select
Range("A1").Select
Sheets("Sheet1").Select
Range("A1").Select

End Sub


Clear is assigned to a clear button & your script to another button.
I get a run time error after I clear the sheet with above & reuse your
script.

Any idea??

 

[Sinner]

One way:

No need to trim that I can see.

Dim vArr As Variant
Dim rCell As Range
Dim rDelete As Range
Dim nLow As Long
Dim nHigh As Long
Dim i As Long
Dim sTest As String

With Sheets("Sheet1")
vArr = .Range(.Cells(1, 1), _
.Cells(.Rows.Count, 1).End(xlUp)).Value
End With
nLow = LBound(vArr, 1)
nHigh = UBound(vArr, 1)
With Sheets("Sheet2")
For Each rCell In .Range(.Cells(1, 1), _
.Cells(.Rows.Count, 1).End(xlUp))
sTest = rCell.Text
For i = nLow To nHigh
If sTest = vArr(i, 1) Then
If rDelete Is Nothing Then
Set rDelete = rCell
Else
Set rDelete = Union(rDelete, rCell)
End If
End If
Next i
Next rCell
If Not rDelete Is Nothing Then rDelete.EntireRow.Delete
End With



- Show quoted text -

Dear I have placed your script after a button.
I need to have an error message if any of the two sheets is empty like
"List unavailable. Input list.".

Thx JE McGimpsey,