Save as dialogue box for excel, but pre populating filename from source word document

[algrey7]

Hoping someone can help me finish this off please.

I have put together some code to automate copying content from a source word file, into excel and carry out some formatting etc. Works exactly as required, all good -

Sub QuoteFormat()

Columns("A:A").ColumnWidth = 72.29
Columns("B:D").ColumnWidth = 26.71

Dim WordApp As Object
Dim objDoc As Object
Dim wdFileName As Variant

wdFileName = Application.GetOpenFilename("Word Documents, *.doc*")
If wdFileName = False Then Exit Sub
Set WordApp = CreateObject("Word.Application")
Set objDoc = WordApp.Documents.Open(wdFileName)

WordApp.Selection.WholeStory
WordApp.Selection.Copy

ThisWorkbook.Sheets("Sheet1").Range("A1").Select
ActiveSheet.Paste
objDoc.Close False
WordApp.Quit

Set WordApp = Nothing
Set objDoc = Nothing

Cells.Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

End Sub

However, I would like to add to the end of the sub, for the save as box to open and prepopulate the filename with the filename from the source word document. A couple of nice to haves with this code would be -

- The output file is automatically saved to .xlsx format (don't need macro enabled)
- The original excel file is the master document with the Macro, so cannot be overwritten or changed, so that its in its original state and ready to be used again the next time automation is required for a new document. I guess then will need code to close original excel file without changes?
- The output file will be saved in a number of subfolders deep, so if there's anyway the save as can auto open to a specific sub folder? Only caveat is the macro will be used by multiple users, so assume the file directory will require some sort of wildcard?

Any thoughts or advice greatly appreciated!

 

[Micron]

This might be the hard/long/messy way but I think I would write

If wdfilename <> False Then
   'a) get length of wdfilename: Len(wdfilename)
   'b) get position of last \ with InStrRev() and add 1
   'c) same for period in .docx (or whatever the extension is) but don't add 1
   'd) get filename with Mid(), starting from value returned in b); take n characters. Compute n by subtracting c) from Len()
   'pass the string derived via Mid() to wdfilename
Else
   Exit Sub
End If

IIRC, using msoFileDialogFilepicker will provide the filename property whereas your method returns the whole file path and file name. Not sure as I rarely use GetOpenFileName but perhaps it will also provide just the file name. Would have to play with that.
NOTE - that a,b,c stuff isn't code.

 

[Micron]

Had a bit of time to kill so this seems to work to get the file name:

Dim intSlash As Integer, intDot As Integer, intLen As Integer

If wdFileName <> False Then
    intLen = Len(wdFileName)
    intSlash = InStrRev(wdFileName, "\") + 1
    intDot = InStrRev(wdFileName, ".")
    wdFileName = Mid(wdFileName, intSlash, intDot - intSlash)
Else
    Exit Sub
End If

Somewhere in your code you'll need to turn off Display alerts then SaveAs Filename:=wdFileName & ".xlsx", FileFormat:=51
I'd have to look up how to to ensure original workbook has not been altered (have it somewhere I think). I think it's just about setting saved property to True, which doesn't save but tricks wb into thinking so. Test code given to you on a copy of your workbook and not the original.

As for choosing a location, consider msoFileDialogFolderPicker.

EDIT - I advocate aways using an error handler to prevent altered application settings from being left in an unwanted state if code errors.

 

[algrey7]

Had a bit of time to kill so this seems to work to get the file name:

Dim intSlash As Integer, intDot As Integer, intLen As Integer

If wdFileName <> False Then
    intLen = Len(wdFileName)
    intSlash = InStrRev(wdFileName, "\") + 1
    intDot = InStrRev(wdFileName, ".")
    wdFileName = Mid(wdFileName, intSlash, intDot - intSlash)
Else
    Exit Sub
End If

Somewhere in your code you'll need to turn off Display alerts then SaveAs Filename:=wdFileName & ".xlsx", FileFormat:=51
I'd have to look up how to to ensure original workbook has not been altered (have it somewhere I think). I think it's just about setting saved property to True, which doesn't save but tricks wb into thinking so. Test code given to you on a copy of your workbook and not the original.

As for choosing a location, consider msoFileDialogFolderPicker.

EDIT - I advocate aways using an error handler to prevent altered application settings from being left in an unwanted state if code errors.

Thanks for this, gives me lots of direction to run with! I'll have a play when I get some time and report back.

Thanks again!

 

[RoryA]

You opened the document, so just objDoc.Name will give you its name. If it's always a .docx (or other specific format) you can just use Replace to change that ending into .xlsx to get the Excel file name; if the extension might vary, then you will need to parse it as shown earlier.

 

[algrey7]

You opened the document, so just objDoc.Name will give you its name. If it's always a .docx (or other specific format) you can just use Replace to change that ending into .xlsx to get the Excel file name; if the extension might vary, then you will need to parse it as shown earlier.

Thanks for this! I've not used objDoc.Name before (I am quite the novice to be fair) so will do some research on how / where that code will need to be added.

Thanks for your help!

 

[RoryA]

It will need to be after you open the document here:

Set objDoc = WordApp.Documents.Open(wdFileName)

and before the line where you close it:

objDoc.Close False

You'll want something like:

Dim wordFileName as string
wordfilename = objDoc.Name

then you can use that variable later.

If the master Excel file shouldn't be changed, I'd suggest you have it create a new workbook and paste to that, then save that workbook and close it. That will leave the master open and unchanged.

 

[algrey7]

It will need to be after you open the document here:

Set objDoc = WordApp.Documents.Open(wdFileName)

and before the line where you close it:

objDoc.Close False

You'll want something like:

Dim wordFileName as string
wordfilename = objDoc.Name

then you can use that variable later.

If the master Excel file shouldn't be changed, I'd suggest you have it create a new workbook and paste to that, then save that workbook and close it. That will leave the master open and unchanged.

Thanks for this, I'll have a play.

For the not changing the original WB, can I not use .xltm / macro template?

 

[RoryA]

You can, but I've had people open the template from Excel rather than using File - New, or double-clicking it in Explorer, and then save changes to it.

Here's an example of the approach I suggested:

Sub QuoteFormat()

   Columns("A:A").ColumnWidth = 72.29
   Columns("B:D").ColumnWidth = 26.71
   
   Dim wdFileName As Variant
   wdFileName = Application.GetOpenFilename("Word Documents, *.doc*")
   
   If wdFileName = False Then Exit Sub
   
   Dim tempWb As Workbook
   ThisWorkbook.Sheets("Sheet1").Copy
   Set tempWb = ActiveWorkbook
   
   Dim WordApp As Object
   Set WordApp = CreateObject("Word.Application")
   Dim objDoc As Object
   Set objDoc = WordApp.Documents.Open(wdFileName)
   
   Dim wordFileName As String
   wordFileName = objDoc.Name
   
   WordApp.Selection.WholeStory
   WordApp.Selection.Copy
   
   tempWb.Sheets("Sheet1").Range("A1").PasteSpecial
   objDoc.Close False
   WordApp.Quit
   
   Set WordApp = Nothing
   Set objDoc = Nothing
   
   With tempWb.ActiveSheet.UsedRange
       .HorizontalAlignment = xlGeneral
       .VerticalAlignment = xlBottom
       .WrapText = True
       .Orientation = 0
       .AddIndent = False
       .IndentLevel = 0
       .ShrinkToFit = False
       .ReadingOrder = xlContext
       .MergeCells = False
   End With

   Dim excelFileName As String
   excelFileName = Left$(wordFileName, InStrRev(wordFileName, ".") - 1) & ".xlsx"
   
   Dim fd As FileDialog
   Set fd = Application.FileDialog(msoFileDialogFolderPicker)
   With fd
      If .Show = -1 Then ' check user clicked ok
         tempWb.SaveAs .SelectedItems(1) & "\" & excelFileName, FileFormat:=xlOpenXMLWorkbook
         tempWb.Close False
      End If
   End With
   
End Sub