Vba saving a copy of a single worksheet to different folder

[bamaisgreat]

I currently have a application that people fill out on a userform. When they click on a command button at the end it puts all that information on a sheet i made and then we print it off. My objective is when it saves it to the sheet it also save a copy of that paticular sheet in a seperate location such as H:/applications. Also the copy should be renamed to the information thats in a specific cell Such as j4 the have this text added after that "Application".. thanks

 

[VoG]

Try like this

Sheets("Sheet1").Copy
With ActiveWorkbook
    .SaveAs Filename:="H:\Applications\Application " & Range("J4").Value & ".xls"
    .Close savechanges:=True
End With

 

[bamaisgreat]

Peter Im having trouble getting the code to write over the excisting file each time. The dialog box pops up asking If i want to replace the file. Is there away to add that in the code where it will select yes


Thanks

 

[VoG]

I think this should do it

Sheets("Sheet1").Copy
Application.DisplayAlerts = False
With ActiveWorkbook
    .SaveAs Filename:="H:\Applications\Application " & Range("J4").Value & ".xls"
    .Close savechanges:=True
End With
Application.DisplayAlerts = True

 

[bamaisgreat]

Peter, Could you give me a idea on what to do ? Im struggling on understanding when i copy data to another workbook(Master Archive) then trying to create a copy of it for Public View.
I have pretty much confused my self. The Master Archive is opened up within a macro from several workbooks and then from those workbooks data is transfered to it, but I need a copy of the Master made that will be In a public location. Im unsure if the copy needs to go in the code below or somewhere in the Master Archive workbook
This is the Code Im using in all the workbooks that transfer data, there are about 12 of these.

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("J23").Interior
.Pattern = xlSolid
.PatternColorIndex = 1
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
appendtext = " -FINAL"
.Range("J23").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 FORM")
SourcePath = ActiveWorkbook.Path
SourceFile = Left(ActiveWorkbook.name, InStrRev(ActiveWorkbook.name, ".xls") - 1) & "-PA.xls"
ActiveSheet.Shapes.Range(Array("Button 1982")).Select
Selection.OnAction = "PURCH_COMMENTS_JOB"
Range("$H$1:$K$1").Locked = True

Cells.Select
Selection.Locked = True
Range("V4:V20").Select
Selection.Locked = False
Selection.FormulaHidden = False
ActiveSheet.EnableSelection = xlUnlockedCells
Range("V4").Select
Set rngfil = Range("B4,C4,D4,J4,L4,T4,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)\Archive\Master Archive.xls"
Workbooks.Open (Filename)
With ActiveSheet
.Unprotect Password:="master"
End With

HypoAddress = SourcePath & "\" & SourceFile
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("B" & I + 4).Value
Sheets("Sheet1").Range("B" & NR + I).Value = ws1.Range("C" & I + 4).Value
Sheets("Sheet1").Range("C" & NR + I).Value = ws1.Range("D" & I + 4).Value
Sheets("Sheet1").Range("D" & NR + I).Value = ws1.Range("J" & I + 4).Value
Sheets("Sheet1").Range("E" & NR + I).Value = ws1.Range("L" & 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("J" & I + 4).Address
If Not ws1.Range("J" & I + 4).Value = "" Then
Sheets("Sheet1").Hyperlinks.Add Anchor:=Sheets("Sheet1").Range("H" & NR + I), Address:= _
HypoAddress, SubAddress:= _
HypoSubAddress, TextToDisplay:= _
"FMI SAW JOB"
End If

Next I

ActiveWorkbook.save
With ActiveSheet
.Protect Password:="master"
End With
ActiveWorkbook.save


ActiveWorkbook.Close
.Protect Password:="1288", DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
ThisWorkbook.save

Application.Quit

End Sub