So close and yet... (Pros Only)

[Gordon C]

....so far.

I have a spreadsheet 5000 deep and 90 across. I need the
code below to launch an input box so that when I enter a
value into this box I want any row on which the value
occours to be cut and pasted into a new sheet, all the
while cells/rows on the original sheet are moved upwards.

I'm almost there but I'm left scratching my head.

Any help would be appreciated...

Public Sub transfer()
Worksheets("Sheet1").Activate
Dim lastrow As Long
Dim lastcol As Long
Dim sString As String
sString = InputBox("ENTER YOUR VALUE: ANY ROW ON
WHICH THIS VALUE IS FOUND WILL BE COPIED TO A NEW SHEET")
If sString = "" Then
MsgBox "No search criteria requested.", vbOKOnly +
vbInformation, "Cancel is pressed."
Exit Sub
End If

lastrow = ActiveSheet.UsedRange.Rows.Count
lastcol = ActiveSheet.UsedRange.Columns.Count
Application.ScreenUpdating = False
Dim ir As Long, ic As Long, rd As Long
For ir = lastrow To 1 Step -1
For ic = lastcol To 1 Step -1
Cells(ir, ic).Activate
If UCase(Cells(ir, ic).Value) = UCase(sString) Then
Rows(ir).Copy Destination:=Sheets
(yournewsheet).Range("A1").End(xlDown).Offset(1, 0)
Rows(ir).Delete Shift:=xlUp
ir = ir - 1
ic = lastcol + 1
rd = rd + 1
End If
Next ic
Next ir
Application.ScreenUpdating = True
MsgBox "You have deleted: " & rd & " rows"
End Sub

Cheers

Gordon.

 

[Bob Phillips]

Public Sub transfer()
Dim lastrow As Long
Dim lastcol As Long
Dim ir As Long, ic As Long, rd As Long
Dim sString As String
Dim yournewsheet As String

yournewsheet = "Sheet2"
Worksheets("Sheet1").Activate
sString = InputBox("ENTER YOUR VALUE: ANY ROW ON WHICH THIS VALUE IS
FOUND WILL BE COPIED TO A NEW SHEET")
If sString = "" Then
MsgBox "No search criteria requested.", vbOKOnly + vbInformation,
"Cancel is pressed."
Exit Sub
End If

lastrow = ActiveSheet.UsedRange.Rows.Count
lastcol = ActiveSheet.UsedRange.Columns.Count
Application.ScreenUpdating = False
For ir = lastrow To 1 Step -1
For ic = lastcol To 1 Step -1
If UCase(Cells(ir, ic).Value) = UCase(sString) Then
Rows(ir).Copy Destination:=Sheets(yournewsheet).Range("A" &
Rows.Count).End(xlUp).Offset(1, 0)
Rows(ir).Delete Shift:=xlUp
ir = ir - 1
ic = lastcol + 1
rd = rd + 1
End If
Next ic
Next ir
Application.ScreenUpdating = True
MsgBox "You have deleted: " & rd & " rows"
End Sub

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[Don Guillett]

A slight mod of the example for FIND in vba. Should be quicker and easier

Sub findcopy()
With Sheets("sheet12").Range("a1:a500")
Set c = .Find(2, LookIn:=xlValues)
If Not c Is Nothing Then
firstaddress = c.Address
Do
x = Sheets("sheet2").Cells(Rows.Count, "a").End(xlUp).Row + 1
c.EntireRow.Copy Sheets("sheet2").Cells(x, "a")
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
End Sub

 

[Tom Ogilvy]

What's changed in the last 11 days?