Solved: Automate Several Sheets

Good afternoon,

I have five sheets, let's just say their names are “Name1” ... “Name5” for instance. I enter data ONLY into sheet “Name1” in columns “E:U” twice weekly.

In sheet “Name1” I want to find the last cell with data in column “U”, then go up one row and one column to the right and copy from that cell to the last cell with data in to the right in that row + 1 down to the next row, then place the cursor in the cell one row down in column “E” which will be the first blank cell after data, and finally then shift the worksheet up one row.
The code below is my attempt for sheet "Name1" & "Name2" and as you can see is pretty useless for the fact that it is hard coded and needs to be adjusted EVERY time and does not work properly.

Code:

---

Option Explicit
Option Base 1
Sub Main()
    Dim FindBlankCell As Range
    Dim FindBlankOther As Range
    Set FindBlankCell = Range("E" & Rows.Count).End(xlUp).Offset(1, 0)
    Set FindBlankOther = Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
    With Application
        .ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
    End With
    With Sheets("Name1").Select
        FindBlankCell.Activate
        FindBlankCell.Offset(-1, 17).Select
        Range("V1690:IM1690").Select
        Selection.Copy
        Range("V1691:IM1691").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
            ActiveWindow.SmallScroll Down:=1
        FindBlankCell.Activate
    With Sheets("Name2").Select
        FindBlankOther.Activate
        FindBlankOther.Offset(-1, 0).Select
        Range("B1690:HY1690").Select
        Selection.Copy
        Range("B1691:HY1691").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
            ActiveWindow.SmallScroll Down:=1
        FindBlankOther.Activate
    End With
    End With
    With Application
        .DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
    End With
End Sub

---

In sheets “Name2” to “Name5” I want to find the last cell with data in column “B” and copy from that cell to the last cell with data in to the right in that row + 1 down to the next row, then place the cursor in the cell one row down in column “B” which will be the first blank cell after data, and finally then shift the worksheet up one row.
At the moment I manually highlight these cells and drag the highlighted cells down one row etc.
Thanks in advance.

Kind regards,
PAB

Edited for correction of data.

Good afternoon,

As I said previously I have five sheets, let's just say their names are “Name1” ... “Name5” for instance although in reallity they are not that structured.
I have put this code together but when I run it, the left to right scroll becomes VERY small because in makes ALL columns "A:XFD" viewable if you scroll to the right. I can't seem to get it to only copy upto the last used cell in the row plus one with data in.

Code:

---

Option Explicit
Option Base 1
Sub Automate()
    Dim dtcName1 As Range
    Dim dtcName2 As Range
    Dim dtcName3 As Range
    Dim dtcName4 As Range
    Dim dtcName5 As Range
    With Application
        .ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
    End With
        With Sheets("Name1").Select
        Set dtcName1 = Range("E" & Rows.Count).End(xlUp).Offset(-1, 17)
        dtcName1.Select
        Range(ActiveCell, ActiveCell.EntireRow.Cells(1, Columns.Count).End(xlToRight)).Select
        Selection.Copy
        ActiveCell.Offset(1, 0).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ActiveWindow.SmallScroll Down:=1
        ActiveCell.Offset(1, -17).Select
        With Sheets("Name2").Select
            Set dtcName2 = Range("B" & Rows.Count).End(xlUp)
            dtcName2.Select
            Range(ActiveCell, ActiveCell.EntireRow.Cells(1, Columns.Count).End(xlToRight)).Select
            Selection.Copy
            ActiveCell.Offset(1, 0).Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
            ActiveWindow.SmallScroll Down:=1
            ActiveCell.Offset(1, 0).Select
            With Sheets("Name3").Select
                Set dtcName3 = Range("B" & Rows.Count).End(xlUp)
                dtcName3.Select
                Range(ActiveCell, ActiveCell.EntireRow.Cells(1, Columns.Count).End(xlToRight)).Select
                Selection.Copy
                ActiveCell.Offset(1, 0).Select
                ActiveSheet.Paste
                Application.CutCopyMode = False
                ActiveWindow.SmallScroll Down:=1
                ActiveCell.Offset(1, 0).Select
                With Sheets("Name4").Select
                    Set dtcName4 = Range("B" & Rows.Count).End(xlUp)
                    dtcName4.Select
                    Range(ActiveCell, ActiveCell.EntireRow.Cells(1, Columns.Count).End(xlToRight)).Select
                    Selection.Copy
                    ActiveCell.Offset(1, 0).Select
                    ActiveSheet.Paste
                    Application.CutCopyMode = False
                    ActiveWindow.SmallScroll Down:=1
                    ActiveCell.Offset(1, 0).Select
                    With Sheets("Name5").Select
                        Set dtcName5 = Range("B" & Rows.Count).End(xlUp)
                        dtcName5.Select
                        Range(ActiveCell, ActiveCell.EntireRow.Cells(1, Columns.Count).End(xlToRight)).Select
                        Selection.Copy
                        ActiveCell.Offset(1, 0).Select
                        ActiveSheet.Paste
                        Application.CutCopyMode = False
                        ActiveWindow.SmallScroll Down:=1
                        ActiveCell.Offset(1, 0).Select
                    End With
                End With
            End With
        End With
        Sheets("Name1").Select
    End With
    With Application
        .DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
    End With
End Sub

---

Is there a simplery way to write this Macro.
Thanks in advance.

Kind regards,
PAB

Firstly 90% of that code isn't needed :), why not attach a sample workbook so we can see your structure, show us a before and after and we'll be able to help you!

Thanks for the reply Simon.
Please find the attached file as requested. It is cut down for file size.
Thanks in advance.

Kind regards,
PAB

Edit: I forgot to say that there are many sheets in my workbook but there is only five sheets that need updating because the rest are updated automatically with formulas.

Good evening,

I have managed to reduce the code to the below.
I don't know if it can be reduced anymore?
Anyway, I have one problem with the code, it only executes the ...

Code:

---

ActiveWindow.SmallScroll Down:=1

---

... for sheet "Name2" and NOT for sheet "Name3" to "Name5" for some reason in the ...

Code:

---

MyArray = Array("Name2", "Name3", "Name4", "Name5")

---

Here is the reduced code ...

Code:

---

Option Explicit
Option Base 1
Sub Automate()
    Dim dtcName1 As Range
    Dim dtcNameOther As Range
    Dim MyArray As Variant
    MyArray = Array("Name2", "Name3", "Name4", "Name5")
    With Application
        .ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
    End With
    With Sheets("Name1").Select
        Set dtcName1 = Range("E" & Rows.Count).End(xlUp).Offset(-1, 17)
        dtcName1.Select
        Range(ActiveCell, ActiveCell.EntireRow.Cells(1, Columns.Count).End(xlToRight)).Copy
        ActiveSheet.Paste Destination:=ActiveCell.Offset(1, 0)
        ActiveWindow.SmallScroll Down:=1
        ActiveCell.Offset(2, -17).Select
        With Sheets(MyArray).Select
            Set dtcNameOther = Range("B" & Rows.Count).End(xlUp)
            dtcNameOther.Select
            Range(ActiveCell, ActiveCell.EntireRow.Cells(1, Columns.Count).End(xlToRight)).Copy
            ActiveSheet.Paste Destination:=ActiveCell.Offset(1, 0)
            ActiveCell.Offset(2, 0).Select
            ActiveWindow.SmallScroll Down:=1
        End With
    End With
    Sheets("Name1").Select
    With Application
        .DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
    End With
End Sub

---

Thanks in advance.

Kind regards,
PAB

BTW, I sorted out the problem with ...

Quote:

---

the left to right scroll becomes VERY small because in makes ALL columns "A:XFD" viewable

---

... by changing ...

Code:

---

        Range(ActiveCell, ActiveCell.EntireRow.Cells(1, Columns.Count).End(xlToRight)).Copy

---

... to ...

Code:

---

        Range(ActiveCell, ActiveCell.EntireRow.Cells(1, Columns.Count).End(xlToLeft)).Copy

---

Thanks in advance.

Kind regards,
PAB

Try this

[VBA]Sub Automate()
Dim MyArray As Variant
Dim Cel As Range
Dim sh As Worksheet

MyArray = Array("Name2", "Name3", "Name4", "Name5")
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With

With Sheets("Name1")
Set Cel = .Range("E" & Rows.Count).End(xlUp).Offset(-1, 17)
Range(Cel, .Cells(Cel.Row, Columns.Count)).Resize(2).FillDown
End With

For Each sh In Sheets(MyArray)
Set Cel = sh.Range("B" & Rows.Count).End(xlUp)
Range(Cel, sh.Cells(Cel.Row, Columns.Count)).Resize(2).FillDown
Next
With Application
.DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End Sub
[/VBA]

Thanks MD,

I have adapted the code slightly and the only thing that does NOT work is ...

Code:

---

        Cel.Offset(1, 0).Select
        ActiveWindow.SmallScroll Down:=1

---

... in the MyArray code which goes to the first empty cell in "B" for each and scrolls the sheet up one line for each.
Here is the adapted code ...

Code:

---

Option Explicit
Option Base 1
Sub Automate()
    Dim MyArray As Variant
    Dim Cel As Range
    Dim sh As Worksheet
    MyArray = Array("Name2", "Name3", "Name4", "Name5")
    With Application
        .ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
    End With
    With Sheets("Name1")
        Set Cel = .Range("E" & Rows.Count).End(xlUp).Offset(-1, 17)
        Range(Cel, .Cells(Cel.Row, Columns.Count).End(xlToLeft)).Resize(2).FillDown
        Cel.Offset(2, -17).Select
        ActiveWindow.SmallScroll Down:=1
    End With
    For Each sh In Sheets(MyArray)
        Set Cel = sh.Range("B" & Rows.Count).End(xlUp)
        Range(Cel, sh.Cells(Cel.Row, Columns.Count).End(xlToLeft)).Resize(2).FillDown
        Cel.Offset(1, 0).Select
        ActiveWindow.SmallScroll Down:=1
    Next
    With Application
        .DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
    End With
End Sub

---

Thanks in advance.

Kind regards,
PAB

You need to activate a sheet before you can select a range. Add
.Activate or Sh.Activate as required.
To positively set an opening layout, I would use the SheetActivate event as
[VBA]Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim c As Range
Select Case Sh.Name
Case "Name1"
Set c = Sh.Cells(Rows.Count, 5).End(xlUp)(2)
Case Else
Set c = Sh.Cells(Rows.Count, 2).End(xlUp)(2)
End Select
ActiveWindow.ScrollRow = c.Row - 5
c.Select
End Sub
[/VBA]

Thanks for the reply MD.
I am unsure though how to incorporate this into the code.
Thanks in advance.

Kind regards,
PAB

That code goes in the Workbook module and will run when you activate any sheet. If you prefer, use the Automate2 version and remove the Event code.

Brilliant MD, thanks very much :thumb.

I could not use the "SheetActivate" event because I have many sheets in the Workbook and unfortunately it affects ALL the others as opposed to just those that I wanted.
Anyway, I used the below code and it works perfectly.

Code:

---

Option Explicit
Option Base 1
Sub Automate2()
    Dim MyArray As Variant
    Dim Cel As Range
    Dim Sh As Worksheet
    MyArray = Array("Name2", "Name3", "Name4", "Name5")
    On Error GoTo Exits
    With Application
        .ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
    End With
    With Sheets("Name1")
        Set Cel = .Range("E" & Rows.Count).End(xlUp).Offset(-1, 17)
        Range(Cel, .Cells(Cel.Row, Columns.Count).End(xlToLeft)).Resize(2).FillDown
        .Activate
        Cel.Offset(2, -17).Select
        ActiveWindow.SmallScroll Down:=1
    End With
    For Each Sh In Sheets(MyArray)
        Set Cel = Sh.Range("B" & Rows.Count).End(xlUp)
        Range(Cel, Sh.Cells(Cel.Row, Columns.Count).End(xlToLeft)).Resize(2).FillDown
        Sh.Activate
        Cel.Offset(2, 0).Select
        ActiveWindow.SmallScroll Down:=1
    Next
Exits:
    Sheets("Name1").Select
    With Application
        .DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
    End With
End Sub

---

Thanks again.

Kind regards,
PAB

You could use

[vba]Private Sub Workbook_SheetActivate(ByVal Sh As Object)

Dim c As Range
Select Case Sh.Name
Case "Name1"
Set c = Sh.Cells(Rows.Count, 5).End(xlUp)(2)
ActiveWindow.ScrollRow = c.Row - 5
c.Select
Case "Name2", "Name3", "Name4", "Name5"
Set c = Sh.Cells(Rows.Count, 2).End(xlUp)(2)
ActiveWindow.ScrollRow = c.Row - 5
c.Select
Case Else
'Do Nothing
End Select
End Sub
[/vba]

Thanks MD but I think I will stick with what I have got because using the "SheetActivate" event moves the individual sheets up when they are clicked.
Thanks for your time and effort, it is appreciated.

Kind regards,
PAB