Solved: Amend vba code to add and extra step

[keilah]

Hi People

if i was to amend the following VBA code so that is will also perform the same function for another worksheet that the user could only switch between by click a macro button.

How would i amend the vba code


Sub ads()
Dim STRTROW As Long

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("Deal Selection").Select
Range("i9:i" & Cells(65536, "i").End(xlUp).Row).Copy
Sheets("Allocation (Base)").Select
STRTROW = Cells(65336, "c").End(xlUp).Row + 1
Range("C" & STRTROW).Select
Selection.PasteSpecial Paste:=xlPasteValues
ENDROW = Cells(65336, "c").End(xlUp).Row
Sheets("Deal Selection").Select
z = Range("B" & Cells(65536, "B").End(xlUp).Row).Value
Sheets("Allocation (Base)").Select
Range("B" & STRTROW & ":B" & ENDROW).Select
Selection.Value = z
Range("d" & STRTROW & ":d" & ENDROW).Select
Selection.Value = Range("D" & STRTROW - 1).Value
Sheets("Deal Selection").Select
Range("B1").Select
Application.CutCopyMode = False

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

[keilah]

Apologies the other worksheet is called "Allocation (vol)"

[keilah]

ok solved it here is the code

Sub ads2()
Dim STRTROW As Long

Sheets("Allocation (Vol)").Visible = True
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("Deal Selection").Select
Range("i9:i" & Cells(65536, "i").End(xlUp).Row).Copy
Sheets("Allocation (Vol)").Select
STRTROW = Cells(65336, "c").End(xlUp).Row + 1
Range("C" & STRTROW).Select
Selection.PasteSpecial Paste:=xlPasteValues
ENDROW = Cells(65336, "c").End(xlUp).Row
Sheets("Deal Selection").Select
z = Range("B" & Cells(65536, "B").End(xlUp).Row).Value
Sheets("Allocation (Vol)").Select
Range("B" & STRTROW & ":B" & ENDROW).Select
Selection.Value = z
Range("d" & STRTROW & ":d" & ENDROW).Select
Selection.Value = Range("D" & STRTROW - 1).Value
Sheets("Deal Selection").Select
Range("B1").Select
Sheets("Allocation (Vol)").Visible = False
Application.CutCopyMode = False

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Edited by Aussiebear: to include the code within the vba tags

[mdmackillop]

Hi Keilah,
To make your code efficient, easier to understand and maintain, get rid of the Selections and make use of variable names


Option Explicit
Sub ads()
Dim STRTROW As Long, ENDROW As Long, z
Dim wsSource As Worksheet
Dim wsTarget As Worksheet

Set wsSource = Sheets("Deal Selection")
Set wsTarget = Sheets("Allocation (Base)")

With wsTarget
STRTROW = .Cells(65336, "C").End(xlUp).Row + 1
wsSource.Range("I9:I" & wsSource.Cells(65536, "i").End(xlUp).Row).Copy
.Range("C" & STRTROW).PasteSpecial Paste:=xlPasteValues
ENDROW = .Cells(65336, "C").End(xlUp).Row
z = wsSource.Cells(65536, "B").End(xlUp).Value
.Range("B" & STRTROW & ":B" & ENDROW).Value = z
.Range("D" & STRTROW & ":D" & ENDROW).Value = .Range("D" & STRTROW - 1).Value
'Leave A1 active
Tidy wsTarget
End With
Application.CutCopyMode = False

End Sub
Sub Tidy(sh As Worksheet)
sh.Range("A1").Copy
sh.Range("A1").PasteSpecial xlPasteAll
End Sub

[mdmackillop]

I see you also crossposted here (http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_23375796.html). You have been previously warned regarding this.

[keilah]

apologies if for got to add the note..........

regards this

[mdmackillop]

There is no note in either posting. Suspended for 3 days.

[rbrhodes]

Hi keilah,

Here's how I would do it...

EDIT: Wow missed a lot while I was looking at the post!



Option Explicit
Sub ads()
Dim z As Variant
Dim eMsg As Long
Dim InSht As Long
Dim EndRow As Long
Dim StartRow As Long
Dim wsDest As Worksheet
Dim wsSource As Worksheet

'Handle errors
On Error GoTo endo

'Ask user for sheet name
InSht = InputBox("Enter 1 for Allocation (Base) or 2 for Allocation (vol)", "Choose Destination sheet", 1)

'Check response and so requested
If InSht = 1 Then
Set wsDest = Sheets("Allocation (Base)")
ElseIf InSht = 2 Then
Set wsDest = Sheets("Allocation (vol)")
Else
'Invalid response or cancelled
Exit Sub
End If

Set wsSource = Sheets("Deal Selection")

'Speed
Application.ScreenUpdating = False

With wsSource
'Get last row of data
EndRow = .Range("I65536").End(xlUp).Row
'Copy range
.Range("I9:I" & EndRow).Copy
End With

With wsDest
'Get destination row
StartRow = .Cells(65336, "C").End(xlUp).Row + 1
'Paste special to destination row
.Cells(StartRow, "C").PasteSpecial Paste:=xlPasteValues
'Get last row of data
EndRow = wsSource.Range("B65536").End(xlUp).Row
'Populate 'z' with value
z = wsSource.Range("B" & EndRow)
'Get last row of data
EndRow = .Cells(65336, "C").End(xlUp).Row
'Put 'z' value in all rows
.Range("B" & StartRow & ":B" & EndRow) = z
'Copy D value down
.Range("D" & StartRow & ":D" & EndRow) = .Range("D" & StartRow - 1).Value
End With

'JIC
wsSource.Activate
Range("B1").Select

'Reset
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
'Normal exit
Exit Sub
'Errored out
endo:
'Reset
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With

'Inform user
eMsg = MsgBox("Error! " & Err.Number & " " & Err.Description, vbCritical)
End Sub