VBA: Code MONSTROSITY, EMBARRASSED TO SHOW BUT "NEED HELP".

B

bamaisgreat

Well-known Member
Joined
Jan 23, 2012
Messages
834
Office Version
  1. 365
Platform
  1. Windows
The code I have below is a major overkill but It works except there is a couple of bugs. The first is when I run the code, on the last line((Set rngfil = Range("A20,B20,C20,D20,J20,R20,U20"))) it puts in the "-" in the Range of cells, I dont need that. Each line may not always have data in it and sometimes there may only be a few of the cells with data in them. The reason I chose the "-" is so no cell will be empty to prevent the line of cells from getting out of line. Any help is appreciated, Thanks

Code: 
Sub ArchiveIt()
'next line adds character into empty cell'
Dim rngfil As Range, cell As Range
Dim NR As Long
Set ws1 = ActiveWorkbook.Sheets("JOB FORM")
Set rngfil = Range("A4,B4,C4,D4,J4,R4,U4")
Set rngfil = Range("A5,B5,C5,D5,J5,R5,U5")
Set rngfil = Range("A6,B6,C6,D6,J6,R6,U6")
Set rngfil = Range("A7,B7,C7,D7,J7,R7,U7")
Set rngfil = Range("A8,B8,C8,D8,J8,R8,U8")
Set rngfil = Range("A9,B9,C9,D9,J9,R9,U9")
Set rngfil = Range("A10,B10,C10,D10,J10,R10,U10")
Set rngfil = Range("A11,B11,C11,D11,J11,R11,U11")
Set rngfil = Range("A12,B12,C12,D12,J12,R12,U12")
Set rngfil = Range("A13,B13,C13,D13,J13,R13,U13")
Set rngfil = Range("A14,B14,C14,D14,J14,R14,U14")
Set rngfil = Range("A15,B15,C15,D15,J15,R15,U15")
Set rngfil = Range("A16,B16,C16,D16,J16,R16,U16")
Set rngfil = Range("A17,B17,C17,D17,J17,R17,U17")
Set rngfil = Range("A18,B18,C18,D18,J18,R18,U18")
Set rngfil = Range("A19,B19,C19,D19,J19,R19,U19")
Set rngfil = Range("A20,B20,C20,D20,J20,R20,U20")
For Each cell In rngfil
 If cell.Value = vbNullString Then
 cell.Value = "-"
 End If
 Next cell
Filename = "H:\Burney Table\CUTTING FORMS (Protected by QC)\fmi archive\My Book.xls"
Workbooks.Open (Filename)
 
NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet1").Range("A" & NR).Value = ws1.Range("A4").Value
    Sheets("Sheet1").Range("B" & NR).Value = ws1.Range("B4").Value
    Sheets("Sheet1").Range("C" & NR).Value = ws1.Range("C4").Value
    Sheets("Sheet1").Range("D" & NR).Value = ws1.Range("D4").Value
    Sheets("Sheet1").Range("E" & NR).Value = ws1.Range("J4").Value
    Sheets("Sheet1").Range("F" & NR).Value = ws1.Range("R4").Value
    Sheets("Sheet1").Range("G" & NR).Value = ws1.Range("T4").Value
    Sheets("Sheet1").Range("H" & NR).Value = ws1.Range("U4").Value
NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet1").Range("A" & NR).Value = ws1.Range("A5").Value
    Sheets("Sheet1").Range("B" & NR).Value = ws1.Range("B5").Value
    Sheets("Sheet1").Range("C" & NR).Value = ws1.Range("C5").Value
    Sheets("Sheet1").Range("D" & NR).Value = ws1.Range("D5").Value
    Sheets("Sheet1").Range("E" & NR).Value = ws1.Range("J5").Value
    Sheets("Sheet1").Range("F" & NR).Value = ws1.Range("R5").Value
    Sheets("Sheet1").Range("G" & NR).Value = ws1.Range("T5").Value
    Sheets("Sheet1").Range("H" & NR).Value = ws1.Range("U5").Value
NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet1").Range("A" & NR).Value = ws1.Range("A6").Value
    Sheets("Sheet1").Range("B" & NR).Value = ws1.Range("B6").Value
    Sheets("Sheet1").Range("C" & NR).Value = ws1.Range("C6").Value
    Sheets("Sheet1").Range("D" & NR).Value = ws1.Range("D6").Value
    Sheets("Sheet1").Range("E" & NR).Value = ws1.Range("J6").Value
    Sheets("Sheet1").Range("F" & NR).Value = ws1.Range("R6").Value
    Sheets("Sheet1").Range("G" & NR).Value = ws1.Range("T6").Value
    Sheets("Sheet1").Range("H" & NR).Value = ws1.Range("U6").Value
 NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet1").Range("A" & NR).Value = ws1.Range("A7").Value
    Sheets("Sheet1").Range("B" & NR).Value = ws1.Range("B7").Value
    Sheets("Sheet1").Range("C" & NR).Value = ws1.Range("C7").Value
    Sheets("Sheet1").Range("D" & NR).Value = ws1.Range("D7").Value
    Sheets("Sheet1").Range("E" & NR).Value = ws1.Range("J7").Value
    Sheets("Sheet1").Range("F" & NR).Value = ws1.Range("R7").Value
    Sheets("Sheet1").Range("G" & NR).Value = ws1.Range("T7").Value
    Sheets("Sheet1").Range("H" & NR).Value = ws1.Range("U7").Value
 NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet1").Range("A" & NR).Value = ws1.Range("A8").Value
    Sheets("Sheet1").Range("B" & NR).Value = ws1.Range("B8").Value
    Sheets("Sheet1").Range("C" & NR).Value = ws1.Range("C8").Value
    Sheets("Sheet1").Range("D" & NR).Value = ws1.Range("D8").Value
    Sheets("Sheet1").Range("E" & NR).Value = ws1.Range("J8").Value
    Sheets("Sheet1").Range("F" & NR).Value = ws1.Range("R8").Value
    Sheets("Sheet1").Range("G" & NR).Value = ws1.Range("T8").Value
    Sheets("Sheet1").Range("H" & NR).Value = ws1.Range("U8").Value
 NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet1").Range("A" & NR).Value = ws1.Range("A9").Value
    Sheets("Sheet1").Range("B" & NR).Value = ws1.Range("B9").Value
    Sheets("Sheet1").Range("C" & NR).Value = ws1.Range("C9").Value
    Sheets("Sheet1").Range("D" & NR).Value = ws1.Range("D9").Value
    Sheets("Sheet1").Range("E" & NR).Value = ws1.Range("J9").Value
    Sheets("Sheet1").Range("F" & NR).Value = ws1.Range("R9").Value
    Sheets("Sheet1").Range("G" & NR).Value = ws1.Range("T9").Value
    Sheets("Sheet1").Range("H" & NR).Value = ws1.Range("U9").Value
 NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet1").Range("A" & NR).Value = ws1.Range("A10").Value
    Sheets("Sheet1").Range("B" & NR).Value = ws1.Range("B10").Value
    Sheets("Sheet1").Range("C" & NR).Value = ws1.Range("C10").Value
    Sheets("Sheet1").Range("D" & NR).Value = ws1.Range("D10").Value
    Sheets("Sheet1").Range("E" & NR).Value = ws1.Range("J10").Value
    Sheets("Sheet1").Range("F" & NR).Value = ws1.Range("R10").Value
    Sheets("Sheet1").Range("G" & NR).Value = ws1.Range("T10").Value
    Sheets("Sheet1").Range("H" & NR).Value = ws1.Range("U10").Value
 NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet1").Range("A" & NR).Value = ws1.Range("A11").Value
    Sheets("Sheet1").Range("B" & NR).Value = ws1.Range("B11").Value
    Sheets("Sheet1").Range("C" & NR).Value = ws1.Range("C11").Value
    Sheets("Sheet1").Range("D" & NR).Value = ws1.Range("D11").Value
    Sheets("Sheet1").Range("E" & NR).Value = ws1.Range("J11").Value
    Sheets("Sheet1").Range("F" & NR).Value = ws1.Range("R11").Value
    Sheets("Sheet1").Range("G" & NR).Value = ws1.Range("T11").Value
    Sheets("Sheet1").Range("H" & NR).Value = ws1.Range("U11").Value
NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet1").Range("A" & NR).Value = ws1.Range("A12").Value
    Sheets("Sheet1").Range("B" & NR).Value = ws1.Range("B12").Value
    Sheets("Sheet1").Range("C" & NR).Value = ws1.Range("C12").Value
    Sheets("Sheet1").Range("D" & NR).Value = ws1.Range("D12").Value
    Sheets("Sheet1").Range("E" & NR).Value = ws1.Range("J12").Value
    Sheets("Sheet1").Range("F" & NR).Value = ws1.Range("R12").Value
    Sheets("Sheet1").Range("G" & NR).Value = ws1.Range("T12").Value
    Sheets("Sheet1").Range("H" & NR).Value = ws1.Range("U12").Value
NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet1").Range("A" & NR).Value = ws1.Range("A13").Value
    Sheets("Sheet1").Range("B" & NR).Value = ws1.Range("B13").Value
    Sheets("Sheet1").Range("C" & NR).Value = ws1.Range("C13").Value
    Sheets("Sheet1").Range("D" & NR).Value = ws1.Range("D13").Value
    Sheets("Sheet1").Range("E" & NR).Value = ws1.Range("J13").Value
    Sheets("Sheet1").Range("F" & NR).Value = ws1.Range("R13").Value
    Sheets("Sheet1").Range("G" & NR).Value = ws1.Range("T13").Value
    Sheets("Sheet1").Range("H" & NR).Value = ws1.Range("U13").Value
NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet1").Range("A" & NR).Value = ws1.Range("A14").Value
    Sheets("Sheet1").Range("B" & NR).Value = ws1.Range("B14").Value
    Sheets("Sheet1").Range("C" & NR).Value = ws1.Range("C14").Value
    Sheets("Sheet1").Range("D" & NR).Value = ws1.Range("D14").Value
    Sheets("Sheet1").Range("E" & NR).Value = ws1.Range("J14").Value
    Sheets("Sheet1").Range("F" & NR).Value = ws1.Range("R14").Value
    Sheets("Sheet1").Range("G" & NR).Value = ws1.Range("T14").Value
    Sheets("Sheet1").Range("H" & NR).Value = ws1.Range("U14").Value
NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet1").Range("A" & NR).Value = ws1.Range("A15").Value
    Sheets("Sheet1").Range("B" & NR).Value = ws1.Range("B15").Value
    Sheets("Sheet1").Range("C" & NR).Value = ws1.Range("C15").Value
    Sheets("Sheet1").Range("D" & NR).Value = ws1.Range("D15").Value
    Sheets("Sheet1").Range("E" & NR).Value = ws1.Range("J15").Value
    Sheets("Sheet1").Range("F" & NR).Value = ws1.Range("R15").Value
    Sheets("Sheet1").Range("G" & NR).Value = ws1.Range("T15").Value
    Sheets("Sheet1").Range("H" & NR).Value = ws1.Range("U15").Value
NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet1").Range("A" & NR).Value = ws1.Range("A16").Value
    Sheets("Sheet1").Range("B" & NR).Value = ws1.Range("B16").Value
    Sheets("Sheet1").Range("C" & NR).Value = ws1.Range("C16").Value
    Sheets("Sheet1").Range("D" & NR).Value = ws1.Range("D16").Value
    Sheets("Sheet1").Range("E" & NR).Value = ws1.Range("J16").Value
    Sheets("Sheet1").Range("F" & NR).Value = ws1.Range("R16").Value
    Sheets("Sheet1").Range("G" & NR).Value = ws1.Range("T16").Value
    Sheets("Sheet1").Range("H" & NR).Value = ws1.Range("U16").Value
NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet1").Range("A" & NR).Value = ws1.Range("A17").Value
    Sheets("Sheet1").Range("B" & NR).Value = ws1.Range("B17").Value
    Sheets("Sheet1").Range("C" & NR).Value = ws1.Range("C17").Value
    Sheets("Sheet1").Range("D" & NR).Value = ws1.Range("D17").Value
    Sheets("Sheet1").Range("E" & NR).Value = ws1.Range("J17").Value
    Sheets("Sheet1").Range("F" & NR).Value = ws1.Range("R17").Value
    Sheets("Sheet1").Range("G" & NR).Value = ws1.Range("T17").Value
    Sheets("Sheet1").Range("H" & NR).Value = ws1.Range("U17").Value
NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet1").Range("A" & NR).Value = ws1.Range("A18").Value
    Sheets("Sheet1").Range("B" & NR).Value = ws1.Range("B18").Value
    Sheets("Sheet1").Range("C" & NR).Value = ws1.Range("C18").Value
    Sheets("Sheet1").Range("D" & NR).Value = ws1.Range("D18").Value
    Sheets("Sheet1").Range("E" & NR).Value = ws1.Range("J18").Value
    Sheets("Sheet1").Range("F" & NR).Value = ws1.Range("R18").Value
    Sheets("Sheet1").Range("G" & NR).Value = ws1.Range("T18").Value
    Sheets("Sheet1").Range("H" & NR).Value = ws1.Range("U18").Value
NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet1").Range("A" & NR).Value = ws1.Range("A19").Value
    Sheets("Sheet1").Range("B" & NR).Value = ws1.Range("B19").Value
    Sheets("Sheet1").Range("C" & NR).Value = ws1.Range("C19").Value
    Sheets("Sheet1").Range("D" & NR).Value = ws1.Range("D19").Value
    Sheets("Sheet1").Range("E" & NR).Value = ws1.Range("J19").Value
    Sheets("Sheet1").Range("F" & NR).Value = ws1.Range("R19").Value
    Sheets("Sheet1").Range("G" & NR).Value = ws1.Range("T19").Value
    Sheets("Sheet1").Range("H" & NR).Value = ws1.Range("U19").Value
NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Sheet1").Range("A" & NR).Value = ws1.Range("A20").Value
    Sheets("Sheet1").Range("B" & NR).Value = ws1.Range("B20").Value
    Sheets("Sheet1").Range("C" & NR).Value = ws1.Range("C20").Value
    Sheets("Sheet1").Range("D" & NR).Value = ws1.Range("D20").Value
    Sheets("Sheet1").Range("E" & NR).Value = ws1.Range("J20").Value
    Sheets("Sheet1").Range("F" & NR).Value = ws1.Range("R20").Value
    Sheets("Sheet1").Range("G" & NR).Value = ws1.Range("T20").Value
    Sheets("Sheet1").Range("H" & NR).Value = ws1.Range("U20").Value

   
    ActiveWorkbook.save
    'ActiveWorkbook.Close
End Sub
 
Sort by date Sort by votes
bama,

Does this do it?

Code as before + new lines shown red.

Take care because I have not tested!!!!!!

Rich (BB code): 
Sub ArchiveIt()
Dim rngfil As Range, cell As Range
Dim NR As Long, I As Long
Set ws1 = ActiveWorkbook.Sheets("JOB FORM")

SourcePath = ActiveWorkbook.Path
SourceFile = ActiveWorkbook.Name

Set rngfil = Range("A4,B4,C4,D4,J4,R4,U4") 'first row of data to be processed
For r = 0 To 16  '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)\fmi archive\My Book.xls"
Workbooks.Open (Filename)

HypoForm = "=HYPERLINK('" & SourcePath & "\[" & SourceFile & "]" & ws1.Name & "'"

NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
For I = 0 To 16
    Sheets("Sheet1").Range("A" & NR + I).Value = ws1.Range("A" & 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("D" & 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("R" & 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
    If Not ws1.Range("A" & I + 4).Value = "" Then Sheets("Sheet1").Range("I" & NR + I).Formula = HypoForm & ws1.Range("A" & I + 4).Address
Next I
   
    'ActiveWorkbook.Save
    'ActiveWorkbook.Close
End Sub
 
Upvote 0
Tony, the code ran fine until it got down to
Sheets("Sheet1").Range("I" & NR + I).Formula = HypoForm & ws1.Range("A" & I + 4).Address
Click to expand...
It turned all of the above to yellow
and had error:
Run-time error '1004
Method'Open" of object "workbooks" failed
Im not sure whats up with it.....
 
Upvote 0
Tony forget what I said above after I changed the style of the column to hyperlink it started working.
When It puts the File path and file name in the column it doesnt seem to be a real hyperlink it appears as below in the cells
[TABLE="width: 617"]
<tbody>[TR]
[TD]=HYPERLINK('H:\Burney Table\Fmi saw Archive\[FMI SAW Archive test.xls]JOB FORM'$A$8


But it does not hyperlink>
THanks Jamey[/TD]
[/TR]
</tbody><colgroup><col></colgroup>[/TABLE]
 
Upvote 0
Tony I put the code in a different workbook that had a few more rows and it debugs on the red text below.Thanks for all your help.
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
Set ws1 = ActiveWorkbook.Sheets("JOB CUTTING FORM")

SourcePath = ActiveWorkbook.Path
SourceFile = ActiveWorkbook.name

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

ActiveSheet.Shapes.Range(Array("Button 206")).Select
Selection.OnAction = "PURCH_COMMENTS_JOB"

Range("$g$1:$j$1").Locked = True

Cells.Select
Selection.Locked = True
Range("v4:v22").Select
Selection.Locked = False
Selection.FormulaHidden = False
ActiveSheet.EnableSelection = xlUnlockedCells
Range("v4").Select
Set rngfil = Range("A4,B4,C4,G4,I4,S4,T4") 'first row of data to be processed
For r = 0 To 16 '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 = "C:\Users\JEpperson\Documents\Burney Table-1\CUTTING FORMS (Protected by QC)\PC Archive\PC Excel Archive.xls"
Workbooks.Open (Filename)

HypoForm = "=HYPERLINK('" & SourcePath & "\[" & SourceFile & "]" & ws1.name & "'"

NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
For I = 0 To 19
Sheets("Sheet1").Range("A" & NR + I).Value = ws1.Range("A" & 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("G" & I + 4).Value
Sheets("Sheet1").Range("E" & NR + I).Value = ws1.Range("I" & I + 4).Value
Sheets("Sheet1").Range("F" & NR + I).Value = ws1.Range("S" & 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
If Not ws1.Range("A" & I + 4).Value = "" Then Sheets("Sheet1").Range("H" & NR + I).Formula = HypoForm & ws1.Range("A" & I + 4).Address
Next I
'ActiveWorkbook.Save
'ActiveWorkbook.Close
.Protect Password:="1288", DrawingObjects:=True, Contents:=True, Scenarios:=True
End With

With ActiveWorkbook
oldFileName = .FullName
newFileName = Left(.FullName, InStrRev(.FullName, ".xls") - 1) _
& appendtext
.SaveAs Filename:=newFileName
End With
Kill oldFileName
'Application.Quit
End Sub
Click to expand...
 
Upvote 0
Jamey,

Are you saying that sometimes the data will extend beyond Row 20 ie the data range is variable?

If so is there any one of of the data columns that can be used to test where the last row is?

Was the hyperlink code working properly at any stage or not?
 
Upvote 0
As for the hyperlink it will show the info below,but it will not do anything. No it has not worked thus far.
=HYPERLINK('H:\Burney Table\Fmi saw Archive\[FMI SAW Archive test.xls]JOB FORM'$A$4

the code does not go below 20.
When I step thru the code it will go thru and add the data to one row then when it gets to
Then Sheets("Sheet1").Range("H" & NR + I).Formula = HypoForm & ws1.Range("A" & I + 4).Address
it stops
 
Upvote 0
Jamey,

As I stated when I posted the hyperlink code, I had not tested it. Had I done so I would have realised that the approach was somewhat flawed. Hence it don't work and the code errored as your last post.

I have played further with the .Formula approach to creating the hyperlink but even using the correct syntax I still can't get it to work.

So I have modified the approach as per the code below.

Give it a try and let me know if it is ok.



Rich (BB code): 
Dim newFileName As String
Dim appendtext As String
Dim rngfil As Range, cell As Range
Dim NR As Long, I As Long
Set ws1 = ActiveWorkbook.Sheets("JOB CUTTING FORM")

SourcePath = ActiveWorkbook.Path
SourceFile = ActiveWorkbook.name

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

ActiveSheet.Shapes.Range(Array("Button 206")).Select
Selection.OnAction = "PURCH_COMMENTS_JOB"

Range("$g$1:$j$1").Locked = True

Cells.Select
Selection.Locked = True
Range("v4:v22").Select
Selection.Locked = False
Selection.FormulaHidden = False
ActiveSheet.EnableSelection = xlUnlockedCells
Range("v4").Select
Set rngfil = Range("A4,B4,C4,G4,I4,S4,T4") 'first row of data to be processed
For r = 0 To 16 '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 = "C:\Users\JEpperson\Documents\Burney Table-1\CUTTING FORMS (Protected by QC)\PC Archive\PC Excel Archive.xls"
Workbooks.Open (Filename)

HypoAddress = SourcePath & "\" & SourceFile

NR = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
For I = 0 To 19
Sheets("Sheet1").Range("A" & NR + I).Value = ws1.Range("A" & 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("G" & I + 4).Value
Sheets("Sheet1").Range("E" & NR + I).Value = ws1.Range("I" & I + 4).Value
Sheets("Sheet1").Range("F" & NR + I).Value = ws1.Range("S" & 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


HypoSubAddress = "'" & ws1.Name & "'" & "!" & ws1.Range("A" & I + 4).Address

    If Not ws1.Range("A" & I + 4).Value = "" Then
    Sheets("Sheet1").Hyperlinks.Add Anchor:=Sheets("Sheet1").Range("I" & NR + I), Address:= _
        HypoAddress, SubAddress:= _
        HypoSubAddress, TextToDisplay:= _
        "Link To...."
    End If


Next I
'ActiveWorkbook.Save
'ActiveWorkbook.Close
.Protect Password:="1288", DrawingObjects:=True, Contents:=True, Scenarios:=True
End With

With ActiveWorkbook
oldFileName = .FullName
newFileName = Left(.FullName, InStrRev(.FullName, ".xls") - 1) _
& appendtext
.SaveAs Filename:=newFileName
End With
Kill oldFileName
'Application.Quit
End Sub
 
Upvote 0
Tony, this is AWESOME ! Works great so far. Ive been looking for this Answer for over a year. I appreciate it so much.
I do have one small modification that I need and cant seem to figure out were to add it.
In the code as you notice the filename is saved with the additional "-FINAL on the end of it.
At the next stage that someone opens this workbook they review and run a simple macro that modifies the filename to have a "-PA" at the end of it. So it looks like this in the End result "Filename-Final-PA.xls " My question is can some where in your coding for the hyperlink can the "-PA" be added to the filename ? I realize the hyperlink will not work immediatly because the actual filename and hyperlink path will be different. But after the next user gets done and the PA is added to the filename it will.
The reason for this is I would like to monitior the data thats getting transfered..

Code: 
Sub Newhyperlink()
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
Set ws1 = ActiveWorkbook.Sheets("JOB CUTTING FORM")
SourcePath = ActiveWorkbook.Path
SourceFile = ActiveWorkbook.name

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("A4,B4,C4,H4,J4,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 = "C:\Users\JEpperson\Documents\Burney Table-1\CUTTING FORMS (Protected by QC)\PC Archive\PC Excel Archive.xls"
Workbooks.Open (Filename)
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("A" & 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("T" & I + 4).Value
Sheets("Sheet1").Range("G" & NR + I).Value = ws1.Range("U" & I + 4).Value
'Sheets("Sheet1").Range("H" & NR + I).Value = ws1.Range("U" & I + 4).Value

HypoSubAddress = "'" & ws1.name & "'" & "!" & ws1.Range("A" & I + 4).Address
    If Not ws1.Range("A" & I + 4).Value = "" Then
    Sheets("Sheet1").Hyperlinks.Add Anchor:=Sheets("Sheet1").Range("H" & NR + I), Address:= _
        HypoAddress, SubAddress:= _
        HypoSubAddress, TextToDisplay:= _
        "Link To...."
    End If

Next I
'ActiveWorkbook.Save
'ActiveWorkbook.Close
.Protect Password:="1288", DrawingObjects:=True, Contents:=True, Scenarios:=True
End With

End Sub
 
Upvote 0
Jamey,

Edit the line
Code: 
 SourceFile = ActiveWorkbook.name

to

Code: 
  SourceFile = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".xls") - 1) & "-PA.xls"

That should do it.
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Solved
VBA Loop through range to copy/paste values not working
2 3
Replies
20
Views
439
rossross
R
C
  • Solved
Min/Max
Replies
8
Views
88
Joe4
Joe4
K
  • Solved
vba run time error 424
Replies
3
Views
122
Peter_SSs
Peter_SSs
S
  • Solved
Return error if "Filter" doesn't return the required entry
Replies
2
Views
286
skittlz
S
C
  • Solved
Copy data from multiple sheets into a master sheet - VBA button stuck
Replies
3
Views
588
NdNoviceHlp
NdNoviceHlp

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top