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]

ok, works. Many thanks Worf

 

[beczer]

Hey, Last question I have small problem.

Currently my Macro exports data from two worksheets: Cells 1-16(extCRM), and Range(Excel).

Everything works well but I would also like to export cells 1-3 from sheet1 from the same worksheet as Range (Excel)
Is it possible to find some solution for that ?

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$
  sTargetFolder = Environ("UserProfile") & "\" & Sheets("DocDataSource").Range("M2").Value
    If Dir(sTargetFolder, vbDirectory) = "" 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") & "\" & ThisWorkbook.Sheets("Path").Cells(1))
    wdapp.ScreenUpdating = True
     StrName = sTargetFolder & "\" & ThisWorkbook.Sheets("Path").Cells(2) & " " & Format(Now, "yyyy-mm-dd hh-mm-ss")
 
   
    ThisWorkbook.Worksheets("Excel").Range("A2:E24").Copy
    doc.Bookmarks("Table").Range.Paste
    
[COLOR=#ff0000]    [/COLOR]
[COLOR=#ff0000]    For r = 1 To 16[/COLOR]
[COLOR=#ff0000]        doc.Bookmarks(wksCRM.Cells(r, "A").Value).Range.Text = wksCRMExt.Cells(r, "B").Value[/COLOR]
[COLOR=#ff0000]          [/COLOR]
[COLOR=#ff0000]  [/COLOR][COLOR=#006600][FONT=Courier]  [/FONT][/COLOR]With ThisWorkbook.Worksheets("Sheet1")[COLOR=#ff0000]
For r = 1 To 3[/COLOR]
[COLOR=#ff0000]        doc.Bookmarks(Sheet1.Cells(r, "A").Value).Range.Text = Sheet1.Cells(r, "B").Value[/COLOR]
   
Next r
    doc.SaveAs2 StrName & ".docx", wdFormatXMLDocument
    doc.SaveAs2 StrName & ".pdf", wdFormatPDF
      End With
End Sub

 

[Worf]

See if this example helps:

Sub SomeSub()
Dim r As Integer, wdapp As Word.Application, doc As Word.Document, wkbCRMExt As Workbook
Dim wksCRMExt As Worksheet, sTargetFolder$, sname$, wksCRM, wb1
Set wb1 = ThisWorkbook                                                       ' one workbook
sTargetFolder = Environ("UserProfile") & "\" & wb1.Sheets("DocDataSource").Range("M2")
If Dir(sTargetFolder, vbDirectory) = "" Then MkDir sTargetFolder
Set wkbCRMExt = Workbooks.Open(Environ("UserProfile") & "\Desktop\CRM.xlsx") ' another workbook
Set wksCRMExt = wkbCRMExt.Sheets(1)
Set wdapp = New Word.Application
wdapp.Visible = True
Set doc = wdapp.Documents.Open(Environ("UserProfile") & "\" & wb1.Sheets("Path").Cells(1))
wdapp.ScreenUpdating = True
Set wksCRM = ThisWorkbook.Sheets(1)
sname = sTargetFolder & "\" & wb1.Sheets("Path").Cells(2) & " " & _
Format(Now, "yyyy-mm-dd hh-mm-ss")
wb1.Worksheets("Excel").Range("A2:E25").Copy
doc.Bookmarks("Table").Range.Paste
For r = 1 To 2
    doc.Bookmarks(wksCRM.Cells(r, "A")).Range.Text = wksCRMExt.Cells(r, "B")
Next
For r = 1 To 3
    doc.Bookmarks(Plan1.Cells(r, "A")).Range.Text = Plan1.Cells(r, "B")
Next
wb1.Worksheets("Sheet1").[a1:b3].Copy                           ' desired range here
doc.Bookmarks("Table").Range.Paste                              ' desired bookmark here
'doc.SaveAs2 sname & ".docx", wdFormatXMLDocument
'doc.SaveAs2 sname & ".pdf", wdFormatPDF
MsgBox "End of code!"
End Sub