excelvbainsertcopyshared

Excel cut and insert based on a cell value


In a shared workbook I'm getting a 1004 error about: "Insert method of range failed."

I have been using the following code for years. (Non shared mode)

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
Dim wb As Workbook
Dim ws1 As Worksheet
Dim x As Integer
Dim y As Integer
Dim score As Long
Dim scoreRow As Long
Set wb = ActiveWorkbook
Application.EnableEvents = False
Application.ScreenUpdating = False
If Target.Column >= 2 And Target.Column <= 10 And Target.Row >= 5 And 
  Target.Row <= 9 Then
  Set ws1 = Worksheets(1)
  For x = 10 To 19
    score = ws1.Cells(x, 14).Value
    scoreRow = x
      For y = x + 1 To 19
        If ws1.Cells(y, 14).Value > score Then
        score = ws1.Cells(y, 14).Value
        scoreRow = y
  End If 'strange... It looks to stay better after the next code line...
     Next y
 'Next x is missing, too...

If scoreRow <> x Then
  ws1.Cells(scoreRow, 13).Cut
  ws1.Cells(x, 13).Insert
  ws1.Cells(scoreRow, 14).Cut
  ws1.Cells(x, 14).Insert
End If
ActiveWorkbook.Save
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Any help to adjust to a Shared workbook would be great. The rows 10 to 19 only contain the data i am manupulating (sorting)


Solution

  • As a result, you should end up with code like this:

    Option Explicit
    
    Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
        Dim wb          As Workbook
        Dim ws1         As Worksheet
        Dim x           As Integer
        Dim y           As Integer
        Dim score       As Long
        Dim scoreRow    As Long
        Set wb = ActiveWorkbook
        Application.ScreenUpdating = False
        Application.EnableEvents = False
    
        If Target.Column >= 2 And Target.Column <= 10 And Target.Row >= 5 And Target.Row <= 9 Then
            Set ws1 = Worksheets(1)
    
            For x = 10 To 19
                score = ws1.Cells(x, 14).Value
                scoreRow = x
    
                For y = x + 1 To 19
    
                    If ws1.Cells(y, 14).Value > score Then
                        score = ws1.Cells(y, 14).Value
                        scoreRow = y
                    End If    'strange... It looks to stay better after the next code line...
    
                Next y
                'Next x is missing, too...
    
                If scoreRow <> x Then
                    ws1.Cells(scoreRow, 13).Cut
                    ws1.Cells(x, 13).Insert
                    ws1.Cells(scoreRow, 14).Cut
                    ws1.Cells(x, 14).Insert
                End If
    
                ActiveWorkbook.Save
            Next
    
        End If
    
        Application.CutCopyMode = False
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End Sub