Moving rows upwards ... one at a time

[fluffynicesheep]

Hi,

I currently have some code that looks at data in row 2 of a worksheet. After pressing a button, the VBA pulls the information from the cells in that particular row, through to other cells in the workbook, it then automatically saves this info as a new document and then returns to the first worksheet and moves the data upwards, so that row 3 has now become row 2 etc....

Basically I can't delete row 1 or row 2, as this will mess up all the formulas in the other tabs ... so found this to be the best way of doing it!.

Sure enough the first time I press the button, it does everything I want ... all the info in row 2 goes into the correct cells in other parts of the workbook, it then saves the document, returns to the original page, and the subsequent rows all move up 1 - meaning row 2 disappears and row 3 becomes the new row 2 ... so the new lot of data is now present throughout the rest of the workbook.


However, when I run the VBA for a 2nd time it now runs as normal, it saves the document with the new name, but it now stops on this line ......

.Range("A2:MN" & LastRow - 1).Value = .Range("A3:MN" & LastRow).Value

So there's some issues with moving up the rows again!!

Not sure why this is any different from the first time I have pressed the button ... so consider myself stumped!!

If anyone has any ideas that would be great.

This is the full code that I have:

Sub Rectangle3_Click()
Dim wbA As Workbook
Dim wbB As Workbook
Dim strFileName As String
Dim DataSheet As Worksheet
Dim MyRange As Range
Dim LastRow As Long


Set DataSheet = Sheets("AEB - Copy Values")
With DataSheet
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If LastRow = 2 Then Exit Sub


    Application.ScreenUpdating = False

    Set wbA = ThisWorkbook

    wbA.Sheets("NCS - Copy Values Skip Blanks").Visible = True
    
    wbA.Sheets("NCS - Copy Values Skip Blanks").Copy

    Set wbB = ActiveWorkbook

    With wbB
    
        With .Sheets(1).UsedRange
            .Copy
            .PasteSpecial xlValues
            .PasteSpecial xlFormats
        End With
        
        Dim nm As Name
Dim DeleteCount As Long

'Loop through each name and delete
  For Each nm In ActiveWorkbook.Names
    On Error GoTo Skip
    
    If SkipPrintAreas = True And Right(nm.Name, 10) = "Print_Area" Then GoTo Skip
    
    nm.Delete
    DeleteCount = DeleteCount + 1

Skip:
    
  Next
  
'Reset Error Handler
  On Error GoTo 0
     
'Report Result
  If DeleteCount = 1 Then
    MsgBox "[1] name was removed from this workbook."
  Else
    MsgBox "[" & DeleteCount & "] names were removed from this workbook."
  End If


        Application.CutCopyMode = False

        strFileName = .Sheets(1).Range("FW9").Value

        .SaveAs wbA.Path & Application.PathSeparator & strFileName & ".xlsb", xlExcel12
        .Close SaveChanges:=False
    End With
    wbA.Sheets("NCS - Copy Values Skip Blanks").Visible = False
    Sheets("AEB - Copy Values").Select
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
Cells(1, 1).Activate
ActiveCell.Next.Select
Application.ScreenUpdating = True


Application.ScreenUpdating = False
.Range("A2:MN" & LastRow - 1).Value = .Range("A3:MN" & LastRow).Value
.Range("A" & LastRow & ":MN" & LastRow).ClearContents
Application.ScreenUpdating = True
End With
End Sub

 

[DanteAmor]

However, when I run the VBA for a 2nd time it now runs as normal, it saves the document with the new name, but it now stops on this line ......

.Range("A2:MN" & LastRow - 1).Value = .Range("A3:MN" & LastRow).Value

What does the error message say?

I did tests with sample data and I have no problems.
Maybe something with your data. You have merged cells. Is the sheet protected?

 

[fluffynicesheep]

Hi,

No it' not protected at all.

The error message I get is:

Run Time error 6 - overflow

Then when I click ok ... it highlights this line of code:

.Range("A2:MN" & LastRow - 1).Value = .Range("A3:MN" & LastRow).Value

 

[DanteAmor]

How many lines does your database have?

 

[fluffynicesheep]

Hi Dante,

I'm going to be looking at a maximum of around 40 rows that will need to be moved up one at a time ... so that particular button may have to be pressed around 38 times, until it works it's way to the top (or row 2).

Once it gets to row 2, I then click another button to import a different set of 40 (or similar rows) - again this starts on row 2, and could go back down to row 40 or similar ..... the looping process would then start again for this lot of information.

So there definitely isn't a lot of data, so not sure why there is an overflow!

 

[DanteAmor]

Try the following.
What it does is pass row 3 to row 2, then pass row 4 to row 2 and so on until it reaches the last row with data.
With this macro it is not necessary to execute it 40 times, the macro will automatically execute the executions of the 40 rows.

Sub Rectangle3_Click()
  Dim wbA As Workbook, wbB As Workbook, DataSheet As Worksheet, nm As Name
  Dim strFileName As String, i As Long, SkipPrintAreas
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set wbA = ThisWorkbook
  Set DataSheet = wbA.Sheets("AEB - Copy Values")
  
  wbA.Sheets("NCS - Copy Values Skip Blanks").Visible = True
  For i = 3 To DataSheet.Cells(DataSheet.Rows.Count, 1).End(xlUp).Row
    DataSheet.Range("A2:MN2").Value = DataSheet.Range("A" & i & ":MN" & i).Value
    wbA.Sheets("NCS - Copy Values Skip Blanks").Copy
    Set wbB = ActiveWorkbook
    With wbB.Sheets(1).UsedRange
      .Copy
      .PasteSpecial xlValues
      .PasteSpecial xlFormats
      Application.CutCopyMode = False
    End With
    
    On Error Resume Next  'Loop through each name and delete
    For Each nm In wbB.Names
      If Not (SkipPrintAreas = True And Right(nm.Name, 10) = "Print_Area") Then nm.Delete
    Next
    On Error GoTo 0 'Reset Error Handler
    
    strFileName = wbB.Sheets(1).Range("FW9").Value
    wbB.SaveAs wbA.Path & Application.PathSeparator & strFileName & ".xlsb", xlExcel12
    wbB.Close SaveChanges:=False
  Next
End Sub

 

[fluffynicesheep]

Thanks Dante,

I'll have a look as soon as I get back into work tomorrow morning.

 

[DanteAmor]

Of course, let me know any doubt.

 

[fluffynicesheep]

Hi Dante,

Looking good... I've tried it with 6 rows and just a couple of issues:

1) I have data in row 2,3,4,5 and 6...... once I click the button the macro you have sent me produces the required save document for the information contained in rows 3,4,5 and 6 - so is just missing the save for the data that was in row 2 (originally)
2) Once the macro ends, it still shows lines 2,3,4,5,6, etc ..... please can you add a line to the end that deletes rows 3 onwards .. so just leaves row 2.

Apart from that, I think it works really well!

 

[DanteAmor]

Try this

Sub Rectangle3_Click()
  Dim wbA As Workbook, wbB As Workbook, DataSheet As Worksheet, nm As Name
  Dim strFileName As String, i As Long, SkipPrintAreas
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set wbA = ThisWorkbook
  Set DataSheet = wbA.Sheets("AEB - Copy Values")
  
  wbA.Sheets("NCS - Copy Values Skip Blanks").Visible = True
  For i = 2 To DataSheet.Cells(DataSheet.Rows.Count, 1).End(xlUp).Row
    DataSheet.Range("A2:MN2").Value = DataSheet.Range("A" & i & ":MN" & i).Value
    wbA.Sheets("NCS - Copy Values Skip Blanks").Copy
    Set wbB = ActiveWorkbook
    With wbB.Sheets(1).UsedRange
      .Copy
      .PasteSpecial xlValues
      .PasteSpecial xlFormats
      Application.CutCopyMode = False
    End With
    
    On Error Resume Next  'Loop through each name and delete
    For Each nm In wbB.Names
      If Not (SkipPrintAreas = True And Right(nm.Name, 10) = "Print_Area") Then nm.Delete
    Next
    On Error GoTo 0 'Reset Error Handler
    
    strFileName = wbB.Sheets(1).Range("FW9").Value
    wbB.SaveAs wbA.Path & Application.PathSeparator & strFileName & ".xlsb", xlExcel12
    wbB.Close SaveChanges:=False
  Next
  DataSheet.Rows("3:" & rows.count).clearcontents
End Sub