Save/create Folder&File with Name from Cell

[beczer]

Hi everyone.

I need you help.

I have a problem with macro. Everything here works (export to word etc) but there are some things which require to be corrected. Below what I need.

1. Create a Folder in location and with the name from sheet [DocDataSource], cell M2
2. Use a template from path in cell B1 in sheet [DocDataSource]
3. Save in created folder updated template with data from Excel (it works) in docx, pdf, xlms with name from M3, sheet [DocDataSource]

Now I take a template from

ThisWorkbook.Sheets("Path")

but I would like to change and use a path from B1 sheet [DocDataSource] as I mentioned in point 2

Sub SomeSub()
Dim r As Integer
Dim wdapp As Word.Application
Dim doc As Word.Document
Dim wkbCRMExt As Workbook
Dim wksCRMExt As Worksheet
    'Dim sTargetFolder$
    
    Set wkbCRMExt = Workbooks.Open(Environ("UserProfile") & "\Desktop\CRM.xlsx")
    Set wksCRMExt = wkbCRMExt.Sheets(1)
    'TargetFolder = Environ("UserProfile") & "\" & Sheets("DocDataSource").Range("M2").Value
    'If Dir(sTargetFolder, vbDirectory) = "" Then MkDir sTargetFolder
    Set wdapp = New Word.Application
    wdapp.Visible = True
    Set doc = wdapp.Documents.Open(Environ("UserProfile") & "\" & ThisWorkbook.Sheets("Path").Cells(1))
    wdapp.ScreenUpdating = True
     'For i = 1 To 1
'StrName = Environ("UserProfile") & "\" & Sheets("DocDataSource").Cells(i, "B").Value
'Set wdDoc = .Documents.Open(StrName)
'StrName = sTargetFolder & "\" & Cells(i, "F") & " " & Format(Now, "yyyy-mm-dd hh-mm-ss")
            'j = 0
            
   
    ThisWorkbook.Worksheets("Excel").Range("A2:E24").Copy
    doc.Bookmarks("Table2").Range.Paste 'ExcelTable False, True, False
    
    For r = 1 To 5
        doc.Bookmarks(wksCRM.Cells(r, "A").Value).Range.Text = wksCRMExt.Cells(r, "B").Value
    Next r




  '.SaveAs Filename:=StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
  '.SaveAs Filename:=StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
  
End Sub

 

[beczer]

I will be so grateful if someone find a time to solve this problem, help me to do this.

Thanks

 

[beczer]

No idea ?

 

[beczer]

Hey guys, pls help me a little bit with above issue

 

[Worf]

Hi

This relates to the first item; I will be back later with more.

Private Function PathExists(pname) As Boolean
' Returns TRUE if the path exists
If Dir(pname, vbDirectory) = "" Then
    PathExists = False
Else
    PathExists = (GetAttr(pname) And vbDirectory) = vbDirectory
End If
End Function

Sub SomeSub()
Dim wkbCRMExt As Workbook, wksCRMExt As Worksheet, wksCRM, sTargetFolder$
Set wkbCRMExt = Workbooks.Open(Environ("UserProfile") & "\Desktop\CRM.xlsx")
Set wksCRMExt = wkbCRMExt.Sheets(1)
sTargetFolder = Environ("UserProfile") & "\" & Sheets("DocDataSource").[M2]
If Not PathExists(sTargetFolder) Then MkDir sTargetFolder
End Sub

 

[beczer]

Thank you so much Worf

I hope that you will have a time to help with second part as well

 

[Worf]

The second part:

Sub SomeSub()
Dim r As Integer, wdapp As Word.Application, wkscrm, strname$, doc As Word.Document
Dim wksCRMExt As Worksheet, sTargetFolder$, ws As Worksheet
Set ws = Sheets("DocDataSource")
sTargetFolder = Environ("UserProfile") & "\" & ws.Range("M2")
Set wdapp = New Word.Application
wdapp.Visible = True
Set doc = wdapp.Documents.Open(Environ("UserProfile") & "\" & ws.[b1])
wdapp.ScreenUpdating = True
strname = sTargetFolder & "\" & ws.[m3] & " " & Format(Now, "yyyy-mm-dd hh-mm-ss")
doc.SaveAs2 strname & ".docx", wdFormatXMLDocument
doc.SaveAs2 strname & ".pdf", wdFormatPDF
End Sub

 

[beczer]

Many thanks Worf for your time and help

I combined my code with your but there is some errorred) run-time error 9 out of range. I checked cell, name and everything is correct so I don't know why it doesn't work

Private Function PathExists(pname) As Boolean' Returns TRUE if the path exists
If Dir(pname, vbDirectory) = "" Then
    PathExists = False
Else
    PathExists = (GetAttr(pname) And vbDirectory) = vbDirectory
End If
End Function


Sub SomeSub()
Dim wkbCRMExt As Workbook, wksCRMExt As Worksheet, wksCRM, sTargetFolder$
Set wkbCRMExt = Workbooks.Open(Environ("UserProfile") & "\Desktop\CRM.xlsx")
Set wksCRMExt = wkbCRMExt.Sheets(1)
[COLOR=#FF0000]   sTargetFolder = Environ("UserProfile") & "\" & Sheets("DocDataSource").Range("M2").Value[/COLOR]
If Not PathExists(sTargetFolder) Then MkDir sTargetFolder
  
    Set wdapp = New Word.Application
    wdapp.Visible = True
Set doc = wdapp.Documents.Open(Environ("UserProfile") & "\" & ws.[b1])
    wdapp.ScreenUpdating = True
 
    ThisWorkbook.Worksheets("Excel").Range("A2:E24").Copy
    doc.Bookmarks("Table2").Range.Paste
    
    For r = 1 To 5
        doc.Bookmarks(wksCRM.Cells(r, "A").Value).Range.Text = wksCRMExt.Cells(r, "B").Value
    Next r


strname = sTargetFolder & "\" & ws.[m3] & " " & Format(Now, "yyyy-mm-dd hh-mm-ss")
doc.SaveAs2 strname & ".docx", wdFormatXMLDocument
doc.SaveAs2 strname & ".pdf", wdFormatPDF
End Sub

 

[beczer]

Sorry Worf, my mistake. Now it works but there is another issue. Error 424 object required.

I checked bookmarks, template file, crm file - all is fine

Private Function PathExists(pname) As Boolean' Returns TRUE if the path exists
If Dir(pname, vbDirectory) = "" Then
    PathExists = False
Else
    PathExists = (GetAttr(pname) And vbDirectory) = vbDirectory
End If
End Function


Sub SomeSub()
Dim r As Integer, wdapp As Word.Application, wksCRM, strname$, doc As Word.Document
Dim wkbCRMExt As Workbook, wksCRMExt As Worksheet, sTargetFolder$
Set ws = Sheets("DocDataSource")
sTargetFolder = Environ("UserProfile") & "\" & ws.Range("M2")
If Not PathExists(sTargetFolder) Then MkDir sTargetFolder
Set wkbCRMExt = Workbooks.Open(Environ("UserProfile") & "\Desktop\CRM.xlsx")
Set wksCRMExt = wkbCRMExt.Sheets(1)
Set wdapp = New Word.Application
wdapp.Visible = True
Set doc = wdapp.Documents.Open(Environ("UserProfile") & "\" & ws.[b1])
wdapp.ScreenUpdating = True
  ThisWorkbook.Worksheets("Excel").Range("A2:E24").Copy
    doc.Bookmarks("Table2").Range.Paste
    For r = 1 To 5
[COLOR=#ff0000]        doc.Bookmarks(wksCRM.Cells(r, "A").Value).Range.Text = wksCRMExt.Cells(r, "B").Value [/COLOR]
    Next r
wdapp.ScreenUpdating = True
strname = sTargetFolder & "\" & ws.[m3] & " " & Format(Now, "yyyy-mm-dd hh-mm-ss")
doc.SaveAs2 strname & ".docx", wdFormatXMLDocument
doc.SaveAs2 strname & ".pdf", wdFormatPDF
End Sub

 

[beczer]

Seperately it works fine...but when I add your code then there is above error with bookmarks...

Any solution ?

Thanks