Health and Education blog

 =(SUBSTITUTE(CELL("filename"), RIGHT(CELL("filename"),LEN(CELL("filename"))-SEARCH("[",CELL("filename"))+1),""))&C2&".docx"

 Sub copyfiles() 'Updateby http://www.hardipdabhi.wordpress.com     Dim xRg As Range, xCell As Range     Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog     Dim xSPathStr As Variant, xDPathStr As Variant     Dim xVal As String     On Error Resume Next     Set xRg = Application.InputBox("Please select the file names:", "www.hardipdabhi.wordpress.com", ActiveWindow.RangeSelection.Address, , , , , 8)     If xRg Is Nothing Then Exit Sub     Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)     xSFileDlg.Title = "Please select the original folder:"     If xSFileDlg.Show <> -1 Then Exit Sub     xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"     Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)     xDFileDlg.Title = "Please select the destination folder:"     If xDFileDlg.Show <> -1 Then Exit Sub     xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"     For Each xCell In

 Option Explicit Const FOLDER_SAVED As String = "F:\1350\tset\" `Makes sure your folder path ends with a backward slash Const SOURCE_FILE_PATH As String = "F:\1350\microteknik catagog.xlsx" Sub TestRun() Dim MainDoc As Document, TargetDoc As Document Dim dbPath As String Dim recordNumber As Long, totalRecord As Long Set MainDoc = ActiveDocument With MainDoc.MailMerge              '// if you want to specify your data, insert a WHERE clause in the SQL statement         .OpenDataSource Name:=SOURCE_FILE_PATH, sqlstatement:="SELECT * FROM [Sheet1$]"                      totalRecord = .DataSource.RecordCount         For recordNumber = 1 To totalRecord                      With .DataSource                 .ActiveRecord = recordNumber                 .FirstRecord = recordNumber                 .LastRecord = recordNumber             End With                          .Destination = wdSendToNewDocument             .Execute False                          Set Targ

 Sub ConvertWordsToPdfs() 'Updated by Extendoffice 20181123     Dim xIndex As String     Dim xDlg As FileDialog     Dim xFolder As Variant     Dim xNewName As String     Dim xFileName As String     Set xDlg = Application.FileDialog(msoFileDialogFolderPicker)     If xDlg.Show <> -1 Then Exit Sub     xFolder = xDlg.SelectedItems(1) + "\"     xFileName = Dir(xFolder & "*.*", vbNormal)     While xFileName <> ""         If ((Right(xFileName, 4)) <> ".doc" Or Right(xFileName, 4) <> ".docx") Then             xIndex = InStr(xFileName, ".") + 1             xNewName = Replace(xFileName, Mid(xFileName, xIndex), "pdf")             Documents.Open FileName:=xFolder & xFileName, _                 ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _                 PasswordDocument:="", PasswordTemplate:="", Revert:=False, _                 WritePasswordDocume

 Public Sub FitPic() On Error GoTo NOT_SHAPE Dim PicWtoHRatio As Single Dim CellWtoHRatio As Single With Selection PicWtoHRatio = .Width / .Height End With With Selection.TopLeftCell CellWtoHRatio = .Width / .RowHeight End With Select Case PicWtoHRatio / CellWtoHRatio Case Is > 1 With Selection .Width = .TopLeftCell.Width .Height = .Width / PicWtoHRatio End With Case Else With Selection .Height = .TopLeftCell.RowHeight .Width = .Height * PicWtoHRatio End With End Select With Selection .Top = .TopLeftCell.Top .Left = .TopLeftCell.Left End With Exit Sub NOT_SHAPE: MsgBox "Select a picture before running this macro." End Sub

 Sub ExportImages_ExtendOffice() 'Updated by Extendoffice 20220308     Dim xStrPath As String     Dim xStrImgName As String     Dim xImg As Shape     Dim xObjChar As ChartObject     Dim xFD As FileDialog     Set xFD = Application.FileDialog(msoFileDialogFolderPicker)     xFD.Title = "Please select a folder to save the pictures" & " - ExtendOffice"     If xFD.Show = -1 Then        xStrPath = xFD.SelectedItems.Item(1) & "\"     Else         Exit Sub     End If         On Error Resume Next     For Each xImg In ActiveSheet.Shapes         If xImg.TopLeftCell.Column = 6 Then         xStrImgName = xImg.TopLeftCell.Offset(0, -1).Value         If xStrImgName <> "" Then             xImg.Select                         Selection.Copy             Set xObjChar = ActiveSheet.ChartObjects.Add(0, 0, xImg.Width, xImg.Height)             With xObjChar                 .Border.LineStyle = xlLineStyleNone                 .Activate                 Act

 ##################### oem       Remove word warranty        Remove heading installation        Remove heading   ##################### Sub replace() ' ' replace Macro ' '     Selection.Find.ClearFormatting     Selection.Find.Replacement.ClearFormatting     With Selection.Find         .Text = "Should have"         .Replacement.Text = "is has"         .Forward = True         .Wrap = wdFindContinue         .Format = False         .MatchCase = False         .MatchWholeWord = False         .MatchWildcards = False         .MatchSoundsLike = False         .MatchAllWordForms = False     End With     Selection.Find.Execute replace:=wdReplaceAll     With Selection.Find         .Text = "Should be"         .Replacement.Text = "is"         .Forward = True         .Wrap = wdFindContinue         .Format = False         .MatchCase = False         .MatchWholeWord = False         .MatchWildcards = False         .MatchSoundsLike = False         .Mat