how to close unsaved Opend Word information with out save
VBA Code:
Sub FnGetOpenedDocInstance()
Dim WB As Workbook
Dim WS As Worksheet
Dim DfltPth As String
Dim Dfltname As String
Set WB = ThisWorkbook
Set WS = WB.Worksheets(1)
DfltPth = WB.Path
Dfltname = DfltPth & "\CSE.docx"
Dim Rng As Range, InputRng As Range
Set InputRng = WS.Range("B1:B30")
LastRng = WS.Range(InputRng(InputRng.Cells.Count).Address)
On Error Resume Next
Dim WordApp As Word.Application
Set WordApp = GetObject(, "Word.Application")
Dim WordDoc As Word.Document
Dim slction
Dim Cntnt
Dim Cnt As Long
'________________________________________________________________________________________________________________________________________________________________________________________________________ & _
________________________________________________________________________________________________________________________________________________________________________________________________________
' Delete All unSaved Open Documents
For Each WordDoc In WordApp.Documents
If WordDoc.FullName = WordDoc.Name Then
If WordApp.Documents.Count > 1 Then
For I = 1 To WordDoc.Documents.Count - 1
If WordDoc.Saved = True Then
WordDoc.Close , wdDoNotSaveChanges
Else
fltname = DfltPth & "\" & WordDoc.Name & ".docx"
[COLOR=rgb(226, 80, 65)]WordDoc.SaveAs fltname[/COLOR]
WordDoc.Close
Kill fltname
End If
Next
Else
If WordDoc.Saved = True Then
WordDoc.Close , wdDoNotSaveChanges
WordApp.Quit
Else
fltname = DfltPth & "\" & WordDoc.Name & ".docx"
[COLOR=rgb(226, 80, 65)]WordDoc.SaveAs fltname[/COLOR]
WordDoc.Close
WordApp.Quit
Kill fltname
End If
End If
End If
Next
On Error GoTo 0
'________________________________________________________________________________________________________________________________________________________________________________________________________ & _
________________________________________________________________________________________________________________________________________________________________________________________________________
' Create New Doc
Set WordApp = Nothing
Set WordApp = CreateObject("Word.Application")
Set Doc = WordApp.Documents.Add
With WordApp
.Visible = True
.Activate
Set slction = .selection
End With
Set Cntnt = Doc.Content
Dim RngVal As String, TXT As String
'Get Data
TXT = ""
For Each Rng In InputRng
Rw = Rng.Row
Cl = Rng.Column
RngVal = Rng.Value
RngValOSB = WS.Cells(Rw + 1, Cl).Value ' Offset Bottom
RngValOSL = WS.Cells(Rw, Cl - 1).Value ' Offset Left
RngValOSLB = WS.Cells(Rw + 1, Cl - 1).Value ' Offset Left Bottom
If RngValOSL <> "Box" Then
If (RngVal <> "" And Left(RngVal, 1) <> "•" And InStr(TXT, "•") = 0) Then
If Left(RngVal, 1) = "•" Or RngValOSL = "F" Then
TXT = TXT & IIf(TXT <> "", vbNewLine, "") & RngVal
Else
TXT = TXT & " " & RngVal
End If
If Left(RngValOSB, 1) = "•" Or (RngValOSLB = "f" Or RngValOSLB = "F") Or Rng = LastRng Then
MsgBox TXT
TXT = ""
End If
ElseIf (RngVal <> "" And Left(RngVal, 1) = "•") Or (Left(RngVal, 1) <> "•" And InStr(TXT, "•") <> 0) Then
If Left(RngVal, 1) = "•" Or RngValOSL = "F" Then
TXT = TXT & IIf(TXT <> "", vbNewLine, "") & RngVal
Else
TXT = TXT & " " & RngVal
End If
If (RngValOSLB = "f" Or RngValOSLB = "F") Or Rng = LastRng Then
TXT = ""
End If
End If
Else
End If
Next
End Sub