Sub FINALIZED_BY_QC_job()
Dim newFileName As String
Dim appendtext As String
Dim rngfil As Range, cell As Range
Dim NR As Long, I As Long
If UCase(InputBox("Enter Password")) <> "1288" Then Exit Sub
With ActiveSheet
.Unprotect Password:="1288"
With .Range("J24").Interior
.Pattern = xlSolid
.PatternColorIndex = 1
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
appendtext = " -FINAL"
.Range("J24").FormulaR1C1 = appendtext
With ActiveWorkbook
oldFileName = .FullName
newFileName = Left(.FullName, InStrRev(.FullName, ".xls") - 1) _
& appendtext
.SaveAs Filename:=newFileName
End With
Kill oldFileName
ActiveWorkbook.Save
Set ws1 = ActiveWorkbook.Sheets("JOB CUTTING FORM")
SourcePath = ActiveWorkbook.Path
SourceFile = Left(ActiveWorkbook.name, InStrRev(ActiveWorkbook.name, ".xls") - 1) & "-PA.xls"
ActiveSheet.Shapes.Range(Array("Button 192")).Select
Selection.OnAction = "PURCH_COMMENTS_JOB"
Range("$H$1:$K$1").Locked = True
Cells.Select
Selection.Locked = True
Range("W4:W22").Select
Selection.Locked = False
Selection.FormulaHidden = False
ActiveSheet.EnableSelection = xlUnlockedCells
Range("W4").Select
Set rngfil = Range("B4,C4,H4,J4,N4,T4,U4") 'first row of data to be processed
For r = 0 To 18 'row offset variable
EmptyRowCheck = ""
For Each cell In rngfil.Offset(r, 0) 'Concat values of cells in rngfil offset
EmptyRowCheck = EmptyRowCheck & cell
Next cell
If EmptyRowCheck = "" Then GoTo FoundEmptyRow ' if "" empty row of rngfil cells found so stop putting -
For Each cell In rngfil.Offset(r, 0) 'otherwise put - in any empty cell
If cell.Value = vbNullString Then
cell.Value = "-"
End If
Next cell
Next r
FoundEmptyRow: 'stop putting -
' Archive values to ....
Filename = "H:\Burney Table\CUTTING FORMS (Protected by QC)\Archive\Master Archive.xls"
Workbooks.Open (Filename)
With ActiveSheet
.Unprotect Password:=""
End With
HypoAddress = SourcePath & "\" & SourceFile
NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
For I = 0 To 18
Sheets("Sheet1").Range("A" & NR + I).Value = ws1.Range("B" & I + 4).Value
'Sheets("Sheet1").Range("B" & NR + I).Value = ws1.Range("B" & I + 4).Value
Sheets("Sheet1").Range("C" & NR + I).Value = ws1.Range("C" & I + 4).Value
Sheets("Sheet1").Range("D" & NR + I).Value = ws1.Range("H" & I + 4).Value
Sheets("Sheet1").Range("E" & NR + I).Value = ws1.Range("J" & I + 4).Value
Sheets("Sheet1").Range("F" & NR + I).Value = ws1.Range("N" & I + 4).Value
Sheets("Sheet1").Range("G" & NR + I).Value = ws1.Range("T" & I + 4).Value
Sheets("Sheet1").Range("H" & NR + I).Value = ws1.Range("U" & I + 4).Value
'////////////////////NEXT 2 LINES LOOKS IN THE COLUMN TO SEE IF INFO IS IN THERE
'////////////////////SO IT CAN ADD HYPERLINK
HypoSubAddress = "'" & ws1.name & "'" & "!" & ws1.Range("H" & I + 4).Address
If Not ws1.Range("H" & I + 4).Value = "" Then
Sheets("Sheet1").Hyperlinks.Add Anchor:=Sheets("Sheet1").Range("I" & NR + I), Address:= _
HypoAddress, SubAddress:= _
HypoSubAddress, TextToDisplay:= _
"BURNEY 2 JOB"
End If
Next I
ActiveWorkbook.Save
With ActiveSheet
.Protect Password:=""
End With
ActiveWorkbook.Save
ActiveWorkbook.Close
.Protect Password:="1288", DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
ThisWorkbook.Save
On Error Resume Next
Kill "H:\All\Material Prep Archive\(Public)Archive.xls"
On Error GoTo 0
On Error Resume Next
FileCopy Source:="H:\Burney Table\CUTTING FORMS (Protected by QC)\Archive\Master Archive.xls", Destination:= _
"H:\All\Material Prep Archive\(Public)Archive.xls"
Application.Quit
End Sub