Sub SoftCopy()
'Declare variables
Dim NewFileName As String, UCRFileName As String, MaskValue As String, ActionCodeList1 As String
Dim filefirstrow As Long, filelastrow As Long, UCRMainLastRow As Long
Dim RowHeight1 As Long, RowHeight2 As Long, RowHeight3 As Long, RowHeight4 As Long, RowHeight5 As Long, RowHeight6 As Long, RowHeight7 As Long
Dim intPos As Integer, intPosSave As Integer
Dim strUCRDate As String, strUCRPlanFileName As String, strUCRReturnDate As String
Dim strPlanNumber As String, strPlanName As String, strCAM As String, strPlanExceptions As String, strRegisterStamp As String
Dim a As String, b As String, c As String, i As Integer
Dim macroWB As Workbook, newWB As Workbook
Dim macroSh1 As Worksheet, macroSh2 As Worksheet, macroSh3 As Worksheet, macroSh4 As Worksheet, macroSh5 As Worksheet, macroSh6 As Worksheet
Dim newSh1 As Worksheet, newSh2 As Worksheet, newSh3 As Worksheet, newSh4 As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set macroWB = ThisWorkbook
Set macroSh1 = macroWB.Worksheets("Welcome")
Set macroSh2 = macroWB.Worksheets("Template")
Set macroSh3 = macroWB.Worksheets("INSTRUCTION")
Set macroSh4 = macroWB.Worksheets("PAYEES")
If Left(macroSh1.Range("A4"), 4) = "Mask" Or Left(macroSh1.Range("A4"), 4) = "Show" Then
MaskValue = Left(macroSh1.Range("A4"), 4)
Else: MsgBox ("Mask value invalid")
End If
ActionCodeList1 = "1 - STOP - SAME, 2 - STOP - UPDATE, 3 - STOP - BENE, 4 - REMAIN OUTSTANDING"
'---------------------------------------------------
'-- Identifying UCR master file location
'---------------------------------------------------
MsgBox ("WHERE IS THE DATA - Please select the Master .xlsx file to extract data from on the following screen")
UCRFileName = Application.GetOpenFilename("All Files (*.*),*.*", 1, "Select Master File")
If UCRFileName = "False" Then
MsgBox ("Please rerun the macro when your file is ready")
Exit Sub
End If
MsgBox ("WHERE TO SAVE - Please select the folder location to savetemplate data and the new reports on the following screen")
NewFileName = Application.GetSaveAsFilename("Template Data " & Format(Now(), "MM.DD.YYYY"), , , "Specify location to save template data and new reports")
If NewFileName = "False" Then
MsgBox ("Please rerun the macro when your file is ready")
Exit Sub
End If
strUCRDate = InputBox("What date would you like the report to say this is as of? 'REPORT AS OF MM/DD/YYYY'")
strUCRReturnDate = InputBox("What date would you like the report to say this is as of? 'Return the completed report by: MM/DD/YYYY'")
'Loop to remove non-numeric characters from input dates
intPos = 1
Do
intPos = InStr(intPos, NewFileName, "")
If intPos = 0 Then
Exit Do
Else
intPosSave = intPos - 1
intPos = intPos + 1
End If
Loop
NewFileFolder = Left(NewFileName, intPosSave)
macroSh1.Delete
'Set raw file and copy data to macroWB
Set ucrWB = Workbooks.Open(UCRFileName)
Set ucrSh1 = ucrWB.Sheets(1)
ucrSh1.Move Before:=macroSh2
Set macroSh5 = macroWB.Worksheets(1)
macroSh5.Name = "Main Data"
UCRMainLastRow = macroSh5.Rows.Range("A650000").End(xlUp).Row
If MaskValue = "Mask" Then
macroSh5.Range("L:L").Insert
macroSh5.Range("L1") = "=""xxx-xx-""&right(K1,4)"
macroSh5.Range("L1").Copy
macroSh5.Range("L2:L" & UCRMainLastRow).PasteSpecial xlPasteAll
macroSh5.Range("L:L").Copy
macroSh5.Range("L:L").PasteSpecial xlPasteValues
macroSh5.Range("K:K").Delete
End If
macroSh5.Range("A2:N" & UCRMainLastRow).Locked = True
With macroSh5
.Range("A2:N" & UCRMainLastRow).Sort Key1:=.Range("A2"), Order1:=xlAscending, _
Key2:=.Range("G2"), Order2:=xlDescending, _
Key3:=.Range("H2"), Order3:=xlDescending, _
Header:=xlNo, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End With
ucrWB.Close False
'---------------------------------------------------
'-- Set up waypoint tab for mass file creation
'---------------------------------------------------
'Worksheets.Add().Name = "Waypoint"
Set macroSh6 = macroWB.Worksheets.Add
macroSh6.Name = "Waypoint"
macroSh6.Move After:=macroWB.Sheets(macroWB.Sheets.Count) '----> Not sure this will work
macroSh6.Range("A:J").NumberFormat = "@"
macroSh6.Range("B:B").NumberFormat = "MM/DD/YY"
macroSh6.Range("C:C").NumberFormat = "$0.00"
'Get row heights from template
RowHeight1 = macroSh2.Range("1:1").RowHeight
RowHeight2 = macroSh2.Range("2:2").RowHeight
RowHeight3 = macroSh2.Range("3:3").RowHeight
RowHeight4 = macroSh2.Range("4:4").RowHeight
RowHeight5 = macroSh2.Range("5:5").RowHeight
RowHeight6 = macroSh2.Range("6:6").RowHeight
RowHeight7 = macroSh2.Range("7:7").RowHeight
RowHeight8 = macroSh2.Range("8:8").RowHeight
RowHeight9 = macroSh2.Range("9:9").RowHeight
RowHeight10 = macroSh2.Range("10:10").RowHeight
RowHeight11 = macroSh2.Range("11:11").RowHeight
macroSh2.Range("A1:Q11").Copy
'Format "Waypoint" tab
macroSh6.Range("A1").PasteSpecial xlPasteValues
macroSh6.Range("A1").PasteSpecial xlPasteColumnWidths
macroSh6.Range("A1").PasteSpecial xlPasteFormats
macroSh6.Range("1:1").Rows.RowHeight = RowHeight1
macroSh6.Range("2:2").Rows.RowHeight = RowHeight2
macroSh6.Range("3:3").Rows.RowHeight = RowHeight3
macroSh6.Range("4:4").Rows.RowHeight = RowHeight4
macroSh6.Range("5:5").Rows.RowHeight = RowHeight5
macroSh6.Range("6:6").Rows.RowHeight = RowHeight6
macroSh6.Range("7:7").Rows.RowHeight = RowHeight7
macroSh6.Range("8:8").Rows.RowHeight = RowHeight8
macroSh6.Range("9:9").Rows.RowHeight = RowHeight9
macroSh6.Range("10:10").Rows.RowHeight = RowHeight10
macroSh6.Range("11:11").Rows.RowHeight = RowHeight11
With macroSh6.PageSetup
.PrintTitleRows = macroSh6.Rows(11).Address
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.CenterHorizontally = True
.Orientation = xlLandscape
.PaperSize = xlPaperLegal
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With
filelastrow = 1
Do Until filelastrow = UCRMainLastRow
filefirstrow = filelastrow + 1
If Len(macroSh5.Range("A" & filefirstrow)) <= 8 Then
strPlanNumber = macroSh5.Range("A" & filefirstrow)
Else: strPlanNumber = Right("00000000" & macroSh5.Range("A" & filefirstrow), 8)
strPlanNumberWholeCell = macroSh5.Range("A" & filefirstrow) '---------------> This line seems redundant
End If
strPlanNumberWholeCell = macroSh5.Range("A" & filefirstrow)
strPlanName = macroSh5.Range("B" & filefirstrow)
strCAM = macroSh5.Range("C" & filefirstrow)
strPlanExceptions = ""
If Len(macroSh5.Range("D" & filefirstrow)) > 2 Then strPlanExceptions = macroSh5.Range("D" & filefirstrow)
strRegisterStamp = macroSh5.Range("E" & filefirstrow)
strUCRPlanFileName = strPlanNumber & "00ALL" & "UC" & Format(Now(), "MMDD")
NewUCRFileName = NewFileFolder & "" & strUCRPlanFileName & ".xlsx"
filelastrow = macroSh5.Range("A2:A" & UCRMainLastRow).Find(What:=strPlanNumberWholeCell, LookIn:=xlValues, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:= _
False, SearchFormat:=False).Row
macroSh5.Range("F" & filefirstrow & ":N" & filelastrow).Copy
macroSh6.Range("A12").PasteSpecial xlPasteValues
macroSh6.Range("A:Q").WrapText = True
With macroSh6.Range("A12:Q" & filelastrow - filefirstrow + 12).Borders(xlEdgeBottom)
.LineStyle = xlDash
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With macroSh6.Range("A12:Q" & filelastrow - filefirstrow + 12).Borders(xlInsideHorizontal)
.LineStyle = xlDash
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
If strPlanExceptions = "" Then
macroSh6.Range("H3") = ""
With macroSh6.Range("H5:J8")
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
With macroSh6.Range("H5:J8")
If .MergeCells Then
.UnMerge
End If
End With
Else: macroSh6.Range("H5") = strPlanExceptions
End If
macroSh6.Range("A1") = "REPORT AS OF " & strUCRDate
macroSh6.Range("E5") = strUCRReturnDate
macroSh6.Range("E7") = strPlanName
macroSh6.Range("E8").NumberFormat = "@"
macroSh6.Range("E8") = strPlanNumber
macroSh6.Range("E9") = strCAM
macroSh6.Range("J1").NumberFormat = "@"
macroSh6.Range("J1") = strRegisterStamp
'---------------------------------------------------
'-- Formatting for ALL
'---------------------------------------------------
macroSh6.Range("J12:J" & filelastrow - filefirstrow + 12).Locked = False
macroSh6.Range("A11:J11").Locked = False
'macroSh6.Range("A12").Select
ActiveWindow.FreezePanes = True 'is there a way to change reference to activewindow?
'Need to go over this part again
With macroSh6.Range("J12:J" & filelastrow - filefirstrow + 12).Validation
.Delete
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=ActionCodeList1
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
macroSh6.Range("K12:Q" & filelastrow - filefirstrow + 12).FormatConditions.Add Type:=xlExpression, Formula1:= _
"=OR(LEFT($J12,1)=""2"",LEFT($J12,1)=""3"")"
macroSh6.Range("K12:Q" & filelastrow - filefirstrow + 12).FormatConditions(macroSh6.Range("K12:Q" & filelastrow - filefirstrow + 12).FormatConditions.Count).SetFirstPriority
With macroSh6.Range("K12:Q" & filelastrow - filefirstrow + 12).FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.599963377788629
End With
macroSh6.Range("K12:Q" & filelastrow - filefirstrow + 12).FormatConditions(1).StopIfTrue = False
With macroSh6.Range("K12:Q" & filelastrow - filefirstrow + 12).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0.349986266670736
.PatternTintAndShade = 0
End With
macroSh6.Range("K12:Q" & filelastrow - filefirstrow + 12).Locked = False
'---------------------------------------------------
'-- Totals for file
'---------------------------------------------------
macroSh6.Range("A" & filelastrow - filefirstrow + 14) = "TOTAL"
macroSh6.Range("C" & filelastrow - filefirstrow + 14) = "=sum(C12:C" & filelastrow - filefirstrow + 12 & ")"
'Again change reference to ActiveWindow
With ActiveWindow
.ScrollRow = 1
.ScrollColumn = 1
.ScrollRow = ActiveCell.Row
End With
Set newWB = Workbooks.Add
Set newSh1 = newWB.Worksheets(1)
macroSh6.Copy After:=newSh1
Set newSh2 = newWB.Worksheets("Waypoint")
newSh2.Name = strRegisterStamp
newSh1.Delete
macroSh4.Copy After:=newSh2
macroSh3.Copy After:=newSh2
Set newSh3 = newWB.Worksheets("INSTRUCTION")
Set newSh4 = newWB.Worksheets("PAYEES")
'//////////////////////////////////////////////////////////////////////////////////
Dim lastrowSh2 As Long: lastrowSh2 = 0
lastrowSh2 = newSh2.Rows.Range("A500000").End(xlUp).Row
With newSh2
.Range("A11:Q" & lastrowSh2).Sort Key1:=.Range("B11"), Order1:=xlDescending, _
Key2:=.Range("F11"), Order2:=xlAscending, _
Header:=xlYes
MatchCase = False
Orientation = xlTopToBottom
SortMethod = xlPinYin
End With
'//////////////////////////////////////////////////////////////////////////////////
newSh2.Protect Password:="as;dkfjas", AllowFormattingColumns:=True, AllowFiltering:=True, AllowSorting:=True, AllowFormattingCells:=True
newWB.SaveAs NewUCRFileName, 51
newWB.Close
macroSh6.Range("12:" & filelastrow + 12).Delete
Set newWB = Nothing
Set newSh1 = Nothing
Set newSh2 = Nothing
Set newSh3 = Nothing
Set newSh4 = Nothing
Loop
macroSh6.Delete
macroWB.SaveAs NewFileName & ".xlsx", 51
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
