Shift cells up

W

whitoulias

Board Regular
Joined
Jun 22, 2012
Messages
153
Good day everyone

I have this code (command button1) which works just fine. What it does is if cell 02 in sheet1 is "14" then it copies the entire row to sheet2. The same goes for all O column

I would like to change it a little bit.

Instead of copy i would like to cut the row, paste it in sheet2 and shift cells up in sheet1

Any ideas.

Thank u in advance

Code: 
Private Sub CommandButton1_Click()
Dim FirstAddress As String
    Dim myArr As Variant
    Dim Rng As Range
    Dim Rcount As Long
    Dim I As Long
    Dim LastCol As String


    Application.ScreenUpdating = False

    myArr = Array("14")

 

    Rcount = 0
    With Sheets("Sheet1").Range("O1:O1000")
    

        For I = LBound(myArr) To UBound(myArr)


            Set Rng = .Find(What:=myArr(I), _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                FirstAddress = Rng.Address
                Do
                    Rcount = Rcount + 2

                    LastCol = Chr(Worksheets("Sheet1").Range("A" & Rng.Row).End(xlToRight).Column + 64)
                    Worksheets("Sheet1").Range("A" & Rng.Row & ":" & LastCol & Rng.Row).Copy _
                    Destination:=Worksheets("Sheet2").Range("A" & Rcount)
                    'Sheets("Sheet2").Range("A" & Rcount).Value = Rng.Value
                    Set Rng = .FindNext(Rng)
                Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
            End If
        Next I
    End With
    Application.ScreenUpdating = True

End Sub
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Sort by date Sort by votes
Hello,

Perhaps after the copy a delete could work:

Code: 
Private Sub CommandButton1_Click()
Dim FirstAddress As String
    Dim myArr As Variant
    Dim Rng As Range
    Dim Rcount As Long
    Dim I As Long
    Dim LastCol As String

    Application.ScreenUpdating = False
    myArr = Array("14")
 
    Rcount = 0
    With Sheets("Sheet1").Range("O1:O1000")
    
        For I = LBound(myArr) To UBound(myArr)

            Set Rng = .Find(What:=myArr(I), _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                FirstAddress = Rng.Address
                Do
                    Rcount = Rcount + 2
                    LastCol = Chr(Worksheets("Sheet1").Range("A" & Rng.Row).End(xlToRight).Column + 64)
                    
                    With Worksheets("Sheet1").Range("A" & Rng.Row & ":" & LastCol & Rng.Row)
                        .Copy Destination:=Worksheets("Sheet2").Range("A" & Rcount)
                        .Delete Shift:=xlUp
                    End With
                    
                    'Sheets("Sheet2").Range("A" & Rcount).Value = Rng.Value
                    Set Rng = .FindNext(Rng)
                Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
            End If
        Next I
    End With
    Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0
repairman615

Thx for the reply
It works fine but i get a Run-time error '1004':Unable to get the FindNext property of the Range class

Set Rng = .FindNext(Rng) is highlighted
 
Upvote 0
Hi, :)

try:

Code: 
If Not Rng Is Nothing Then
    FirstAddress = Rng.Address
    Do
        Rcount = Rcount + 2

        LastCol = Chr(Worksheets("Sheet1").Range("A" & Rng.Row).End(xlToRight).Column + 64)
        With Worksheets("Sheet1").Range("A" & Rng.Row & ":" & LastCol & Rng.Row)
            .Cut Destination:=Worksheets("Sheet2").Range("A" & Rcount)
        End With
        'Sheets("Sheet2").Range("A" & Rcount).Value = Rng.Value
        Set Rng = .FindNext(Rng)
    Loop While Not Rng Is Nothing
    .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
 
Upvote 0
123456789101112131415
datadata20/05/201122/06/201239928/05/2011datadatadatadatadatadatadatadata14
datadata21/04/201222/06/20126229/04/2012datadatadatadatadatadatadatadata14
datadata21/06/201222/06/2012129/06/2012datadatadatadatadatadatadatadata14

<colgroup><col span="2"><col span="2"><col><col><col span="8"><col></colgroup><tbody>
</tbody>

row 1 have hedings (1,2,etc)
column 15- (o) counts numbers and text form a2:a14
the rows after the last data are empty
 
Upvote 0
Hi, :)

try - on a copy of the worksheet...:biggrin:

Code: 
Private Sub CommandButton1_Click()
    Dim FirstAddress As String
    Dim myArr As Variant
    Dim Rng As Range
    Dim Rcount As Long
    Dim I As Long
    Dim LastCol As String
    Dim rngArea As Range
    Application.ScreenUpdating = False
    myArr = Array("14")
    Rcount = 0
    With Sheets("Sheet1").Range("O1:O1000")
        For I = LBound(myArr) To UBound(myArr)
            Set Rng = .Find(What:=myArr(I), _
                After:=.Cells(.Cells.Count), _
                LookIn:=xlValues, _
                LookAt:=xlWhole, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, _
                MatchCase:=False)
            If Not Rng Is Nothing Then
                FirstAddress = Rng.Address
                Do
                    Rcount = Rcount + 2
                    LastCol = Chr(Worksheets("Sheet1").Range("A" & Rng.Row).End(xlToRight).Column + 64)
                    With Worksheets("Sheet1")
                        .Range("A" & Rng.Row & ":" & LastCol & Rng.Row).Cut _
                        Destination:=Worksheets("Sheet2").Range("A" & Rcount)
                        If Not rngArea Is Nothing Then
                            Set rngArea = Union(rngArea, .Range("A" & Rng.Row & ":" & LastCol & Rng.Row))
                        Else
                            Set rngArea = .Range("A" & Rng.Row & ":" & LastCol & Rng.Row)
                        End If
                    End With
                    'Sheets("Sheet2").Range("A" & Rcount).Value = Rng.Value
                    Set Rng = .FindNext(Rng)
                Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
                If Not rngArea Is Nothing Then rngArea.Delete
            End If
        Next I
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
The row was cut and paste. Row1 however remained blank, was not deleated and shifted up
Plus :) i get a run time error '91'
Object variable or With block variable not set
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress is highlighted
 
Upvote 0
Hi, :)

try:

Code: 
Private Sub CommandButton1_Click()
    Dim strFirstAddress As String
    Dim intLastCol As Integer
    Dim varSearch As Variant
    Dim intCount As Integer
    Dim rngRange As Range
    Dim rngTMP As Range
    Dim lngRow As Long
    On Error GoTo Fin
    Application.ScreenUpdating = False
    varSearch = Array("14")
    intLastCol = ThisWorkbook.Worksheets("Sheet1").Range("A1").End(xlToRight).Column
    For intCount = LBound(varSearch) To UBound(varSearch)
        With ThisWorkbook.Worksheets("Sheet1").Range("O1:O1000")
            Set rngRange = .Find(varSearch(intCount), , xlValues, xlWhole)
            If Not rngRange Is Nothing Then
                strFirstAddress = rngRange.Address
                Do
                    With ThisWorkbook.Worksheets("Sheet1")
                    If rngTMP Is Nothing Then
                        Set rngTMP = .Range(.Cells(rngRange.Row, 1), _
                            .Cells(rngRange.Row, 15))
                    Else
                        Set rngTMP = Application.Union(rngTMP, .Range(.Cells(rngRange.Row, 1), _
                            .Cells(rngRange.Row, 15)))
                    End If
                    lngRow = lngRow + 2
                    .Range(.Cells(rngRange.Row, 1), .Cells(rngRange.Row, intLastCol)).Copy _
                        Destination:=Worksheets("Sheet2").Range("A" & lngRow)
                    Set rngRange = ThisWorkbook.Worksheets("Sheet1").Range("O1:O1000").FindNext(rngRange)
                    If rngRange Is Nothing Then Exit Do
                    End With
                Loop While rngRange.Address <> strFirstAddress
                If Not rngTMP Is Nothing Then rngTMP.Delete
            End If
        End With
    Next intCount
Fin:
    Application.ScreenUpdating = True
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Parse data - Overwrite lines with updated data
Replies
0
Views
223
Scifo
S
K
  • Question
VBA to filter Worksheet on manager column & copy all data to new workbook
Replies
8
Views
854
kizzie37
K
F
  • Solved
Set up print area and avoid printing blank pages (VBA)
2 3
Replies
27
Views
854
jolivanes
jolivanes
M
  • Question
HHelp With Modifying VBA
Replies
4
Views
517
menor59
M
F
  • Solved
Vba code to pull data from multiple tabs to master
Replies
3
Views
537
rlv01
R

Forum statistics

Threads
1,219,161
Messages
6,146,657
Members
450,706
Latest member
LGVBPP

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top