Macro - close workbook (Phantom blank excel workbook stays open)

[dpnab]

Hello,

I'[m trying to create a macro that will automatically close the workbook but what happens is it leaves behind a blank/greyed out excel file, so not even a new workbook.

I can use application.quit but then if there is another excel file open, it will force close that. Any suggestions?

Sub Export_Sheets()
' Note: Leading zeroes in Column C & D to be kept

Dim wbk1 As Workbook, wbk2 As Workbook
Dim sh As Worksheet, rng As Range
Dim LastRow As Long
Dim fldrName As String
' Don't show confirmation window
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Set wbk1 = ThisWorkbook
fldrName = "\\SERVER ADDRESS"

For Each sh In wbk1.Sheets
If sh.Name = "Upload" Then
' Find last row non blank row (where the term blank includes formulas returning "")
LastRow = sh.Cells.Find("*", LookIn:=xlValues, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Set rng = sh.Range("A1").CurrentRegion.Resize(LastRow)
Set wbk2 = Workbooks.Add
wbk2.Sheets(1).Range(rng.Address).Value = rng.Value
rng.Columns("C:D").Copy
wbk2.Sheets(1).Range("C1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
wbk2.Sheets(1).Columns.AutoFit
wbk2.SaveAs Filename:=fldrName & "/" & sh.Name & ".csv", FileFormat:=xlCSV, local:=True
wbk2.Close
End If
Next sh


ActiveWorkbook.Saved = True
ActiveWorkbook.Close
' Allow confirmation windows to appear as normal
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

 

[Takae]

Hope this helps.

Sub Export_Sheets()
' Note: Leading zeroes in Column C & D to be kept

Dim wbk1 As Workbook, wbk2 As Workbook
Dim sh As Worksheet, rng As Range
Dim LastRow As Long
Dim fldrName As String
' Don't show confirmation window
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Set wbk1 = ThisWorkbook
fldrName = "\\SERVER ADDRESS"
With wbk1.Sheets("Upload")
    ' Find last row non blank row (where the term blank includes formulas returning "")
    LastRow = .Cells.Find("*", LookIn:=xlValues, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    Set rng = .Range("A1").CurrentRegion.Resize(LastRow) '.Resize(LastRow,4)?
    rng.Select
    Set wbk2 = Workbooks.Add
    wbk2.Sheets(1).Range(rng.Address).Value = rng.Value
    rng.Columns("C:D").Copy ' If column B of Sheets ("Upload") has some values, I don't think this row and the row below are needed.
    wbk2.Sheets(1).Range("C1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    wbk2.Sheets(1).Columns.AutoFit
    wbk2.SaveAs Filename:=fldrName & "/" & .Name & ".csv", FileFormat:=xlCSV, local:=True
    wbk2.Close
End With

wbk1.Saved = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
If Workbooks.Count = 1 Then
    Application.Quit
Else
    wbk1.Close
End If

' Allow confirmation windows to appear as normal
End Sub

 

[dpnab]

Hope this helps.

Sub Export_Sheets()
' Note: Leading zeroes in Column C & D to be kept

Dim wbk1 As Workbook, wbk2 As Workbook
Dim sh As Worksheet, rng As Range
Dim LastRow As Long
Dim fldrName As String
' Don't show confirmation window
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Set wbk1 = ThisWorkbook
fldrName = "\\SERVER ADDRESS"
With wbk1.Sheets("Upload")
    ' Find last row non blank row (where the term blank includes formulas returning "")
    LastRow = .Cells.Find("*", LookIn:=xlValues, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    Set rng = .Range("A1").CurrentRegion.Resize(LastRow) '.Resize(LastRow,4)?
    rng.Select
    Set wbk2 = Workbooks.Add
    wbk2.Sheets(1).Range(rng.Address).Value = rng.Value
    rng.Columns("C:D").Copy ' If column B of Sheets ("Upload") has some values, I don't think this row and the row below are needed.
    wbk2.Sheets(1).Range("C1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    wbk2.Sheets(1).Columns.AutoFit
    wbk2.SaveAs Filename:=fldrName & "/" & .Name & ".csv", FileFormat:=xlCSV, local:=True
    wbk2.Close
End With

wbk1.Saved = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
If Workbooks.Count = 1 Then
    Application.Quit
Else
    wbk1.Close
End If

' Allow confirmation windows to appear as normal
End Sub

Says "Compile error: End with Without With"

 

[Takae]

Which line? And please delete this line "rng.Select".

 

[dpnab]

Which line? And please delete this line "rng.Select".

Sorry, I copied it incorrectly originally.

I changed "If Workbooks.Count = 1 Then" to 2 and it worked! I guess it technically kept the workbook open during that part. not sure but it works, and I tested it while having another excel workbook open to make sure.