VBA to cut and paste within one worksheet, and then replicating the action in multiple sheets of one workbook

[keenlearner]

When I run a report from a system I am provided with a workbook with a number of worksheets in it. The number of worksheets can vary depending on the parameters that the report is run under. I have used VBA to tidy up the report a bit but I am very much a novice and so am struggling with my next step.

So after tidying up the report already I would be left with a workbook with anything from two worksheets plus. The last worksheet has been renamed “Last” as I do not want anything to be done to this sheet. All worksheets but the “Last” worksheet are currently selected and rows 1-11 on the worksheets selected are highlighted/selected.

There are up to two lists of data on each worksheet, and what I want to do is cut the second list and paste it to appear underneath the first list. The lists are not always the same length, and there are sometimes blank rows in one or both of the lists, so a simple “ctrl + shft + down and right” won’t work.

Below is the formula I have been using, although this seems to work, when I have done some sanity checks it appears to be deleting some rows out on some of the sheets and I can’t work out why. I have tried to attach an image, but not sure it has worked, in the image it shows a sample of what one of the worksheets looks like, as you will see row 32 is blank for table 2 but there is still data underneath that i want to cut and move. It is the data in columns I-P that i want to paste underneath columns A-H. As mentioned, the table lengths differ from tab to tab, and sometimes there is nothing at all in columns I-P. I don't know if the starting position, with worksheets and rows highlighted as mentioned above, has anything to do with it...I just can't figure it out!!

Hopefully this is enough information, but please let me know if more is required or if i need to post this question elsewhere.

Can anyone help, please?

Sub copypaste()

Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Last" Then

For Each cell In ws.Range("J1")
If cell.Value = "" Then
Else
Range("I2").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Cut
Range("A10000").End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next

End If
Next ws

End Sub

 

[RudiS]

Hi,

Will there be more than two tables next to each other that need to be appended below each other? IOW: On sheets, could there be a third list from Q to X ?

 

[RudiS]

Try this code...
It assumes there are only two lists in each sheet.

Sub AppendData()
Dim sh As Worksheet
Dim rS As Range
Dim lD As Long
    Application.ScreenUpdating = False
    For Each sh In Sheets
        If UCase(sh.Name) = "LAST" Then Exit For
        Set rS = Range(sh.Cells(1, "I"), sh.Cells(Rows.Count, "P").End(xlUp))
        lD = sh.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
        rS.Cut sh.Cells(lD, 1)
        sh.Cells(lD, 1).EntireRow.Delete
        On Error Resume Next
        sh.Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        On Error GoTo 0
    Next sh
    Application.ScreenUpdating = True
End Sub

 

[keenlearner]

Hi,

Thank you for your help. It would only ever be two tables, yes, so what you have based the code on is fine. The code you have sent seems to do the trick from first tests, however it overwrites the headers in row 1, which ideally I would like to keep for the first table and remove/not copy across for the second table - are there any tweaks I can make to the formula to do this, please?

Thanks

 

[RudiS]

I have written the macro to preserve the first tables header row and remove the header of the second table when it adds it to te bottom of the first. In my tests simulating this data the macro runs perfectly across the sheets removing the titles from the second table only. I gathered that this should be the case, so I'm not sure why it is not working with your tables??

 

[keenlearner]

I've had a play and worked it out, I didn't have a title in A1 in my data, if i update the prior VBA to put a title in there the code you have provided does the job perfectly.

Thanks

 

[RudiS]

Excellent. TX for the feedback.