PDA

View Full Version : Solved: Automate Several Sheets



PAB
01-12-2012, 08:32 AM
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.

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.

PAB
01-14-2012, 09:27 AM
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.


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

Simon Lloyd
01-14-2012, 09:34 AM
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!

PAB
01-14-2012, 09:50 AM
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.

PAB
01-14-2012, 04:54 PM
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 ...


ActiveWindow.SmallScroll Down:=1
... for sheet "Name2" and NOT for sheet "Name3" to "Name5" for some reason in the ...


MyArray = Array("Name2", "Name3", "Name4", "Name5")
Here is the reduced 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

PAB
01-14-2012, 06:04 PM
BTW, I sorted out the problem with ...


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


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


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

Kind regards,
PAB

mdmackillop
01-14-2012, 07:19 PM
Try this

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

PAB
01-14-2012, 08:04 PM
Thanks MD,

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


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 ...


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

mdmackillop
01-15-2012, 04:28 AM
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
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

PAB
01-15-2012, 08:31 AM
Thanks for the reply MD.
I am unsure though how to incorporate this into the code.
Thanks in advance.

Kind regards,
PAB

mdmackillop
01-15-2012, 09:38 AM
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.

PAB
01-15-2012, 10:27 AM
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.


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

mdmackillop
01-15-2012, 10:48 AM
You could use

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

PAB
01-15-2012, 11:06 AM
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