replaced http://codereview.stackexchange.com/ with https://codereview.stackexchange.com/
This is a follow up with revised code, see the original question and subsequent answer in the following link (Copy, Paste And Format Copy, Paste And Format)
This is a follow up with revised code, see the original question and subsequent answer in the following link (Copy, Paste And Format)
This is a follow up with revised code, see the original question and subsequent answer in the following link (Copy, Paste And Format)
Sub SORT()
'/Sam Buford
' SORT Macro
' 2016年05月23日
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
'/Macro recorded code follows
Range("A:A,B:B,D:D").Select
Range("D1").Activate
Range("A:A,B:B,D:D,I:I,J:J,K:K,L:L").Select
Range("L1").Activate
Range("A:A,B:B,D:D,I:I,J:J,K:K,L:L,N:N,O:O,P:P,Q:Q,R:R,S:S").Select
Range("S1").Activate
Selection.Delete shift:=xlToLeft
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
CleanExit:
Exit Sub
CleanFail:
'/Resets the Application settings, *then* raises the error
On Error GoTo 0
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Err.Raise (Err.Number)
End Sub
Sub Paste()
'/Paste Macro
' 2016年05月23日
On Error GoTo CleanFail
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim LastRow As Long
Dim LastRow2 As Long
Dim LastColumn As Long
Dim StartCell1 As Range
Dim StartCell2 As Range
Dim rng1 As Range
Dim rng2 As Range
Set sht1 = GetWSFromCodeName("Sheet10")
Debug.Print sht1.Name
Set sht2 = GetWSFromCodeName("Sheet8")
Debug.Print sht2.Name
Set StartCell1 = Range("A2")
Set StartCell2 = Range("B2")
'Find Last Row and Column
LastRow = sht1.Cells(sht1.Rows.Count, StartCell1.Column).End(xlUp).Row
LastColumn = sht1.Cells(StartCell1.Row, sht1.Columns.Count).End(xlToLeft).Column
LastRow2 = sht2.Cells(sht2.Rows.Count, StartCell1.Column).End(xlUp).Row
'Select Range And Copy into Final Formula Sheet
sht1.Range(StartCell1, sht1.Cells(LastRow, LastColumn)).Copy Destination:=sht2.Cells(LastRow2 + 1, 2)
'Convert Text in Column C of Final Formula Sheet to Numbers to Allow Advisor Code to Apply
Set rng1 = Range(sht2.Cells(LastRow2, 3), sht2.Cells(LastRow2 + LastRow - 1, 3))
With rng1
.NumberFormat = "0"
.Value = .Value
End With
'Copy Advisor Function down to meet with new Pasted in Data
With sht2
Set rng2 = .Cells(LastRow2, 1)
End With
With rng2
.Copy Destination:=Range(sht2.Cells(LastRow2, 1), sht2.Cells(LastRow2 + LastRow - 1, 1))
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
CleanExit:
Exit Sub
CleanFail:
'/Resets the Application settings, *then* raises the error
On Error GoTo 0
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Err.Raise (Err.Number)
End Sub
Public Sub ReplaceBlanksTeamID()
'/Fill Blank Team ID's Macro
'2016-05-23
On Error GoTo CleanFail
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim LastRow As Long
Dim StartCell1 As Range
Set sht1 = GetWSFromCodeName("Sheet10")
Debug.Print sht1.Name
Set sht2 = GetWSFromCodeName("Sheet8")
Debug.Print sht2.Name
Set StartCell1 = Range("A2")
'Find Last Row
LastRow = sht1.Cells(sht1.Rows.Count, StartCell1.Column).End(xlUp).Row
'Select Range
sht1.Range(StartCell1, sht1.Cells(LastRow, 2)).Select
On Error Resume Next
sht1.Range(sht1.Cells(2, 2), sht1.Cells(LastRow, 2)).Select
With Selection.SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[+1]C"
.Value = .Value
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
CleanExit:
Exit Sub
CleanFail:
'/Resets the Application settings, *then* raises the error
On Error GoTo 0
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Err.Raise (Err.Number)
End Sub
'/This Function allows the worksheet name to change in the workbook as it allows the
'user to set Worksheets to codename variables. By using this function the user can input a
'codename for a worksheet and the function will call the worksheet name of the corresponding
'codename, allowing the user to set worksheet variables to codenames without losing
'functionality usually associated with such variables.
'2016-05-23
Public Function GetWSFromCodeName(CodeName As String) As Worksheet
On Error GoTo CleanFail
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
Dim WS As Worksheet
For Each WS In ThisWorkbook.Worksheets
If StrComp(WS.CodeName, CodeName, vbTextCompare) = 0 Then
Set GetWSFromCodeName = WS
Exit Function
End If
Next WS
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
CleanExit:
Exit Function
CleanFail:
'/Resets the Application settings, *then* raises the error
On Error GoTo 0
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Err.Raise (Err.Number)
End Function
Sub SORT()
'/Sam Buford
' SORT Macro
' 2016年05月23日
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
Range("A:A,B:B,D:D").Select
Range("D1").Activate
Range("A:A,B:B,D:D,I:I,J:J,K:K,L:L").Select
Range("L1").Activate
Range("A:A,B:B,D:D,I:I,J:J,K:K,L:L,N:N,O:O,P:P,Q:Q,R:R,S:S").Select
Range("S1").Activate
Selection.Delete shift:=xlToLeft
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
CleanExit:
Exit Sub
CleanFail:
'/Resets the Application settings, *then* raises the error
On Error GoTo 0
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Err.Raise (Err.Number)
End Sub
Sub Paste()
'/Paste Macro
' 2016年05月23日
On Error GoTo CleanFail
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim LastRow As Long
Dim LastRow2 As Long
Dim LastColumn As Long
Dim StartCell1 As Range
Dim StartCell2 As Range
Dim rng1 As Range
Dim rng2 As Range
Set sht1 = GetWSFromCodeName("Sheet10")
Debug.Print sht1.Name
Set sht2 = GetWSFromCodeName("Sheet8")
Debug.Print sht2.Name
Set StartCell1 = Range("A2")
Set StartCell2 = Range("B2")
'Find Last Row and Column
LastRow = sht1.Cells(sht1.Rows.Count, StartCell1.Column).End(xlUp).Row
LastColumn = sht1.Cells(StartCell1.Row, sht1.Columns.Count).End(xlToLeft).Column
LastRow2 = sht2.Cells(sht2.Rows.Count, StartCell1.Column).End(xlUp).Row
'Select Range And Copy into Final Formula Sheet
sht1.Range(StartCell1, sht1.Cells(LastRow, LastColumn)).Copy Destination:=sht2.Cells(LastRow2 + 1, 2)
'Convert Text in Column C of Final Formula Sheet to Numbers to Allow Advisor Code to Apply
Set rng1 = Range(sht2.Cells(LastRow2, 3), sht2.Cells(LastRow2 + LastRow - 1, 3))
With rng1
.NumberFormat = "0"
.Value = .Value
End With
'Copy Advisor Function down to meet with new Pasted in Data
With sht2
Set rng2 = .Cells(LastRow2, 1)
End With
With rng2
.Copy Destination:=Range(sht2.Cells(LastRow2, 1), sht2.Cells(LastRow2 + LastRow - 1, 1))
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
CleanExit:
Exit Sub
CleanFail:
'/Resets the Application settings, *then* raises the error
On Error GoTo 0
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Err.Raise (Err.Number)
End Sub
Public Sub ReplaceBlanksTeamID()
'/Fill Blank Team ID's Macro
'2016-05-23
On Error GoTo CleanFail
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim LastRow As Long
Dim StartCell1 As Range
Set sht1 = GetWSFromCodeName("Sheet10")
Debug.Print sht1.Name
Set sht2 = GetWSFromCodeName("Sheet8")
Debug.Print sht2.Name
Set StartCell1 = Range("A2")
'Find Last Row
LastRow = sht1.Cells(sht1.Rows.Count, StartCell1.Column).End(xlUp).Row
'Select Range
sht1.Range(StartCell1, sht1.Cells(LastRow, 2)).Select
On Error Resume Next
sht1.Range(sht1.Cells(2, 2), sht1.Cells(LastRow, 2)).Select
With Selection.SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[+1]C"
.Value = .Value
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
CleanExit:
Exit Sub
CleanFail:
'/Resets the Application settings, *then* raises the error
On Error GoTo 0
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Err.Raise (Err.Number)
End Sub
'/This Function allows the worksheet name to change in the workbook as it allows the
'user to set Worksheets to codename variables. By using this function the user can input a
'codename for a worksheet and the function will call the worksheet name of the corresponding
'codename, allowing the user to set worksheet variables to codenames without losing
'functionality usually associated with such variables.
'2016-05-23
Public Function GetWSFromCodeName(CodeName As String) As Worksheet
On Error GoTo CleanFail
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
Dim WS As Worksheet
For Each WS In ThisWorkbook.Worksheets
If StrComp(WS.CodeName, CodeName, vbTextCompare) = 0 Then
Set GetWSFromCodeName = WS
Exit Function
End If
Next WS
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
CleanExit:
Exit Function
CleanFail:
'/Resets the Application settings, *then* raises the error
On Error GoTo 0
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Err.Raise (Err.Number)
End Function
Sub SORT()
'/Sam Buford
' SORT Macro
' 2016年05月23日
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
'/Macro recorded code follows
Range("A:A,B:B,D:D").Select
Range("D1").Activate
Range("A:A,B:B,D:D,I:I,J:J,K:K,L:L").Select
Range("L1").Activate
Range("A:A,B:B,D:D,I:I,J:J,K:K,L:L,N:N,O:O,P:P,Q:Q,R:R,S:S").Select
Range("S1").Activate
Selection.Delete shift:=xlToLeft
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
CleanExit:
Exit Sub
CleanFail:
'/Resets the Application settings, *then* raises the error
On Error GoTo 0
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Err.Raise (Err.Number)
End Sub
Sub Paste()
'/Paste Macro
' 2016年05月23日
On Error GoTo CleanFail
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim LastRow As Long
Dim LastRow2 As Long
Dim LastColumn As Long
Dim StartCell1 As Range
Dim StartCell2 As Range
Dim rng1 As Range
Dim rng2 As Range
Set sht1 = GetWSFromCodeName("Sheet10")
Debug.Print sht1.Name
Set sht2 = GetWSFromCodeName("Sheet8")
Debug.Print sht2.Name
Set StartCell1 = Range("A2")
Set StartCell2 = Range("B2")
'Find Last Row and Column
LastRow = sht1.Cells(sht1.Rows.Count, StartCell1.Column).End(xlUp).Row
LastColumn = sht1.Cells(StartCell1.Row, sht1.Columns.Count).End(xlToLeft).Column
LastRow2 = sht2.Cells(sht2.Rows.Count, StartCell1.Column).End(xlUp).Row
'Select Range And Copy into Final Formula Sheet
sht1.Range(StartCell1, sht1.Cells(LastRow, LastColumn)).Copy Destination:=sht2.Cells(LastRow2 + 1, 2)
'Convert Text in Column C of Final Formula Sheet to Numbers to Allow Advisor Code to Apply
Set rng1 = Range(sht2.Cells(LastRow2, 3), sht2.Cells(LastRow2 + LastRow - 1, 3))
With rng1
.NumberFormat = "0"
.Value = .Value
End With
'Copy Advisor Function down to meet with new Pasted in Data
With sht2
Set rng2 = .Cells(LastRow2, 1)
End With
With rng2
.Copy Destination:=Range(sht2.Cells(LastRow2, 1), sht2.Cells(LastRow2 + LastRow - 1, 1))
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
CleanExit:
Exit Sub
CleanFail:
'/Resets the Application settings, *then* raises the error
On Error GoTo 0
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Err.Raise (Err.Number)
End Sub
Public Sub ReplaceBlanksTeamID()
'/Fill Blank Team ID's Macro
'2016-05-23
On Error GoTo CleanFail
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim LastRow As Long
Dim StartCell1 As Range
Set sht1 = GetWSFromCodeName("Sheet10")
Debug.Print sht1.Name
Set sht2 = GetWSFromCodeName("Sheet8")
Debug.Print sht2.Name
Set StartCell1 = Range("A2")
'Find Last Row
LastRow = sht1.Cells(sht1.Rows.Count, StartCell1.Column).End(xlUp).Row
'Select Range
sht1.Range(StartCell1, sht1.Cells(LastRow, 2)).Select
On Error Resume Next
sht1.Range(sht1.Cells(2, 2), sht1.Cells(LastRow, 2)).Select
With Selection.SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[+1]C"
.Value = .Value
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
CleanExit:
Exit Sub
CleanFail:
'/Resets the Application settings, *then* raises the error
On Error GoTo 0
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Err.Raise (Err.Number)
End Sub
'/This Function allows the worksheet name to change in the workbook as it allows the
'user to set Worksheets to codename variables. By using this function the user can input a
'codename for a worksheet and the function will call the worksheet name of the corresponding
'codename, allowing the user to set worksheet variables to codenames without losing
'functionality usually associated with such variables.
'2016-05-23
Public Function GetWSFromCodeName(CodeName As String) As Worksheet
On Error GoTo CleanFail
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
Dim WS As Worksheet
For Each WS In ThisWorkbook.Worksheets
If StrComp(WS.CodeName, CodeName, vbTextCompare) = 0 Then
Set GetWSFromCodeName = WS
Exit Function
End If
Next WS
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
CleanExit:
Exit Function
CleanFail:
'/Resets the Application settings, *then* raises the error
On Error GoTo 0
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Err.Raise (Err.Number)
End Function
Copy, Paste and Format 2.0
This is a follow up with revised code, see the original question and subsequent answer in the following link (Copy, Paste And Format)
This is a full version of all three "Macros" or subs within the workbook that I'm currently working with. I hope to use much of this as a reference in future automation to many other aspects of the work day that will make life for many of my work colleagues quicker and easier! Huge thanks to @Zak for a great answer, as he suggested this is the current revised code. I'm sure that there are still many things I could change and am still open to suggestions, though by and large this works for my purpose and is plenty quick now, running in under a seconds one after another as each "macro" is not required in all reports (this being an internal non-coding matter). I am currently mainly wondering of any bad habits glaringly obvious to the eye. As always all constructive criticism and critiques are welcome, though don't feel you have to fundamentally change my code as it is acceptable as of now for my use of it.
Sub SORT()
'/Sam Buford
' SORT Macro
' 2016年05月23日
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
Range("A:A,B:B,D:D").Select
Range("D1").Activate
Range("A:A,B:B,D:D,I:I,J:J,K:K,L:L").Select
Range("L1").Activate
Range("A:A,B:B,D:D,I:I,J:J,K:K,L:L,N:N,O:O,P:P,Q:Q,R:R,S:S").Select
Range("S1").Activate
Selection.Delete shift:=xlToLeft
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
CleanExit:
Exit Sub
CleanFail:
'/Resets the Application settings, *then* raises the error
On Error GoTo 0
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Err.Raise (Err.Number)
End Sub
Sub Paste()
'/Paste Macro
' 2016年05月23日
On Error GoTo CleanFail
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim LastRow As Long
Dim LastRow2 As Long
Dim LastColumn As Long
Dim StartCell1 As Range
Dim StartCell2 As Range
Dim rng1 As Range
Dim rng2 As Range
Set sht1 = GetWSFromCodeName("Sheet10")
Debug.Print sht1.Name
Set sht2 = GetWSFromCodeName("Sheet8")
Debug.Print sht2.Name
Set StartCell1 = Range("A2")
Set StartCell2 = Range("B2")
'Find Last Row and Column
LastRow = sht1.Cells(sht1.Rows.Count, StartCell1.Column).End(xlUp).Row
LastColumn = sht1.Cells(StartCell1.Row, sht1.Columns.Count).End(xlToLeft).Column
LastRow2 = sht2.Cells(sht2.Rows.Count, StartCell1.Column).End(xlUp).Row
'Select Range And Copy into Final Formula Sheet
sht1.Range(StartCell1, sht1.Cells(LastRow, LastColumn)).Copy Destination:=sht2.Cells(LastRow2 + 1, 2)
'Convert Text in Column C of Final Formula Sheet to Numbers to Allow Advisor Code to Apply
Set rng1 = Range(sht2.Cells(LastRow2, 3), sht2.Cells(LastRow2 + LastRow - 1, 3))
With rng1
.NumberFormat = "0"
.Value = .Value
End With
'Copy Advisor Function down to meet with new Pasted in Data
With sht2
Set rng2 = .Cells(LastRow2, 1)
End With
With rng2
.Copy Destination:=Range(sht2.Cells(LastRow2, 1), sht2.Cells(LastRow2 + LastRow - 1, 1))
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
CleanExit:
Exit Sub
CleanFail:
'/Resets the Application settings, *then* raises the error
On Error GoTo 0
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Err.Raise (Err.Number)
End Sub
Public Sub ReplaceBlanksTeamID()
'/Fill Blank Team ID's Macro
'2016-05-23
On Error GoTo CleanFail
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim LastRow As Long
Dim StartCell1 As Range
Set sht1 = GetWSFromCodeName("Sheet10")
Debug.Print sht1.Name
Set sht2 = GetWSFromCodeName("Sheet8")
Debug.Print sht2.Name
Set StartCell1 = Range("A2")
'Find Last Row
LastRow = sht1.Cells(sht1.Rows.Count, StartCell1.Column).End(xlUp).Row
'Select Range
sht1.Range(StartCell1, sht1.Cells(LastRow, 2)).Select
On Error Resume Next
sht1.Range(sht1.Cells(2, 2), sht1.Cells(LastRow, 2)).Select
With Selection.SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[+1]C"
.Value = .Value
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
CleanExit:
Exit Sub
CleanFail:
'/Resets the Application settings, *then* raises the error
On Error GoTo 0
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Err.Raise (Err.Number)
End Sub
'/This Function allows the worksheet name to change in the workbook as it allows the
'user to set Worksheets to codename variables. By using this function the user can input a
'codename for a worksheet and the function will call the worksheet name of the corresponding
'codename, allowing the user to set worksheet variables to codenames without losing
'functionality usually associated with such variables.
'2016-05-23
Public Function GetWSFromCodeName(CodeName As String) As Worksheet
On Error GoTo CleanFail
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
Dim WS As Worksheet
For Each WS In ThisWorkbook.Worksheets
If StrComp(WS.CodeName, CodeName, vbTextCompare) = 0 Then
Set GetWSFromCodeName = WS
Exit Function
End If
Next WS
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
CleanExit:
Exit Function
CleanFail:
'/Resets the Application settings, *then* raises the error
On Error GoTo 0
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Err.Raise (Err.Number)
End Function
lang-vb