GreenwoodJennifer
New Member
- Joined
- Mar 5, 2014
- Messages
- 1
Hello
I am not well versed in VB Logic and am tring to update an existing macro to point to a new template. Below is the old macro, can someone tell me where I need to make the updates within the macro to get it to pull in the two new template worksheets. These two macros are related to eachother and I need to update them:
Sub OpenRateSheetTemplate()
Sub CopyRateSheet()
-------
---------
I am not well versed in VB Logic and am tring to update an existing macro to point to a new template. Below is the old macro, can someone tell me where I need to make the updates within the macro to get it to pull in the two new template worksheets. These two macros are related to eachother and I need to update them:
Sub OpenRateSheetTemplate()
Sub CopyRateSheet()
-------
Code:
Sub OpenRateSheetTemplate()
Dim xlApp As Excel.Application
Dim xlTemp As Excel.Workbook
Dim filename As String, fName As String, DirName As String
Dim newFileName As String, varSheet As Variant
varSheet = "HQ Summary"
'ThisWorkbook.Worksheets("Parameter_Constants").Visible = True
DirName = ThisWorkbook.Worksheets("Parameter_Constants").Range("PreRateSheet").Value
filename = ThisWorkbook.Worksheets("Parameter_Constants").Range("PreRateSheetTemplate").Value
Sheets(varSheet).Visible = True
Sheets(varSheet).Select
ThisWorkbook.Worksheets(varSheet).Range("OrderUnitNo").Select
' Check to see if the unit number field (E5) is blank if it is then exit procedure with a message
If (Trim(Range("OrderUnitNo").Value) <> "") And (Len(Trim(Range("OrderUnitNo").Value)) = 6) Then
newFileName = Trim(Range("OrderUnitNo").Value) & ".XLS"
Dim accum As Double
fName = DirName & newFileName
'If this file does not exist then build it and save it - otherwise give user a message
x = Dir(fName)
If Trim(x) = "" Then
x = ""
Set xlApp = New Excel.Application
I
'Open Rate Sheet Template
Set xlTemp = xlApp.Workbooks.Open(filename)
' Save the new workbook with the unitnumber
Select Case Application.Version
Case "11.0"
xlTemp.SaveAs filename:=fName, FileFormat:=56
Case "12.0"
xlTemp.SaveAs filename:=fName, FileFormat:=52
Case "14.0"
xlTemp.SaveAs filename:=fName, FileFormat:=52
End Select
xlApp.Visible = False
'Next transfer selected data to the newly created workbook.
Call WorkbookToRatesheetTransfer(xlTemp, ByVal varSheet, bIncludeActuals:=False)
'Save the Updated Rate Sheet and hand over to user
xlApp.UserControl = True
xlApp.Visible = True
xlTemp.Worksheets(1).Activate
xlTemp.Save
'Done
GoTo Cleanup
Else
'This filename exists - send message to user
MsgBox newFileName & " Already exists in the " & DirName & " directory." & vbCrLf & "Process has aborted.", vbCritical + vbOKOnly, "File Exists"
GoTo Cleanup
End If
Else
'Cannot determine unit number - send message
MsgBox "Must have an Unit Number assigned first, or Unit Number does not = 6.", vbCritical + vbOKOnly, "Missing Data"
End If
Cleanup:
'Dispose of our pointers - the user should have excel open to the rate sheet spreadsheet now
Set xlTemp = Nothing
Set xlApp = Nothing
End Sub
Sub UnHideVehiclePO()
Sheets("Vehicle PO").Visible = True
Sheets("Vehicle PO").Select
Range("B5").Select
End Sub
Code:
Sub CopyRateSheet()
Application.ScreenUpdating = False
Dim varAnswer As Integer, varActiveBook As String
Dim varRGWorkbook As String, varsheetname As String
Dim sSheet1 As String
Dim sSheet2 As String
sSheet1 = "Proforma Rate Sheet"
sSheet2 = "Proforma Ancillary"
On Error Resume Next
' Order_Quote Workbook variable name
varActiveBook = ActiveWorkbook.Name
varsheetname = "HQ Pricing Review"
' Check to see if "HQ Pricing Review" exists, if Yes then ask to delete
If WorksheetExists(sSheet1) Then
varAnswer = MsgBox(sSheet1 & " already exists. Do you want to replace it?", vbQuestion + vbYesNo, "Worksheet Already Exists")
Select Case varAnswer
Case vbNo
' if the user answers no then exit the sub and do nothing
Exit Sub
End Select
End If
'Do not display action
Application.ScreenUpdating = False
'Delete the current sheets in the order workbook
Application.DisplayAlerts = False
ActiveWorkbook.Sheets("HQ Pricing Review").Delete 'Left in just in case this was still around
ActiveWorkbook.Sheets(sSheet1).Delete
ActiveWorkbook.Sheets(sSheet2).Delete
Application.DisplayAlerts = True
' 1. First open ratesheet template
' 2. Populate the ratesheet with data from this workbook
' 3. Copy "Rate Sheet" tab from template to this workbook and rename it to specified tab name
' 4. Then copy and paste special to get rid of all the formula's
' 5. Copy "Ancillary" tab from template to this workbook and rename it to specified tab name
' 6. Then copy and paste special to get rid of all the formula's
' 7. Close the workbook
'Open Rate Sheet Template
Dim filename As String, fName As String, DirName As String, varSheet1 As String, varSourceDoc As String
filename = ThisWorkbook.Worksheets("Parameter_Constants").Range("PreRateSheetTemplate").Value
varSheet1 = "HQ Summary"
'Open rate sheet template into current application
Dim pRatesheetWB As Excel.Workbook
'Set pRatesheetWB = Workbooks.Add(Template:=filename)
Set pRatesheetWB = Workbooks.Open(filename)
'Disable the "Player piano" effect
pRatesheetWB.Application.ScreenUpdating = False
'Populate the ratesheet template
Call WorkbookToRatesheetTransfer(pRatesheetWB, ByVal varSheet1, bIncludeActuals:=True)
'Do Ancillary sheet
Call CopySheetWithDropdowns(pRatesheetWB, "Ancillary", ThisWorkbook, sSheet2, "CST and Operations Processes")
'Do the rate sheet
Call CopySheetWithDropdowns(pRatesheetWB, "Rate Sheet", ThisWorkbook, sSheet1, "CST and Operations Processes")
'Now dispose of the ratesheet template that we have used
Call pRatesheetWB.Close(SaveChanges:=False)
Set pRatesheetWB = Nothing
'Done
GoTo Cleanup
Exit Sub
Cleanup:
Application.ScreenUpdating = True
End Sub
Last edited by a moderator: