'---------------------------------------------------------------------------------------
' Author : The_Prist(Щербаков Дмитрий)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          https://www.excel-vba.ru
'          info@excel-vba.ru
' Purpose:
'---------------------------------------------------------------------------------------
Sub FixBarcodeText()
    Dim sFolder As String, sFiles As String
    Dim wb As Workbook, ws As Worksheet
    Dim shptmpl As Shape, shp As Shape
    'диалог запроса выбора папки с файлами
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'отключаем обновление экрана, чтобы наши действия не мелькали
    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
        If sFiles <> ThisWorkbook.Name Then
            'открываем книгу
            Set wb = Application.Workbooks.Open(sFolder & sFiles)
            Set ws = wb.Sheets(1)
            Set shp = ws.Shapes(1)
            If shptmpl Is Nothing Then
                Set shptmpl = ThisWorkbook.Sheets(1).Shapes.AddLabel(1, shp.Left, shp.Top, shp.Width, shp.Height)
                shptmpl.Name = "_tmplbarcode_"
            End If
            shptmpl.TextEffect.Text = shp.TextEffect.Text
            shptmpl.TextEffect.FontName = "Barcode"
            shptmpl.TextEffect.FontSize = 16
            shptmpl.Copy
            ws.Paste
            With ws.Shapes("_tmplbarcode_")
                .Left = shp.Left
                .Top = shp.Top
            End With
            shp.Delete
            'Закрываем книгу с сохранением изменений
            wb.Close True 'если поставить False - книга будет закрыта без сохранения
        End If
        sFiles = Dir
    Loop
    If Not shptmpl Is Nothing Then
        shptmpl.Delete
    End If
    'возвращаем ранее отключенное обновление экрана
    Application.ScreenUpdating = True
End Sub

Option Explicit
Private WithEvents XLApp As Application

Private Sub Workbook_Open()
    Set XLApp = Excel.Application
End Sub

Private Sub XLApp_WorkbookOpen(ByVal Wb As Workbook)
    Dim bk$
    With Wb.Sheets(1)
        On Error Resume Next
        bk = .DrawingObjects(1).Caption
        If Right(bk, 1) = "@" Then
            .DrawingObjects(1).Delete
            With .Range("J3:M4")
                .Merge
                .HorizontalAlignment = xlRight
                .VerticalAlignment = xlCenter
                .Font.Name = "Barcode"
                .Font.Size = 16
                .Value = bk
                ' &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
                ' ежели нужна картинка
                .CopyPicture Appearance:=xlScreen, Format:=xlPicture
                .Select
                Wb.Sheets(1).Paste
                .ClearContents
                ' &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
            End With
        End If
    End With
End Sub