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