Замена текста и изображения определенной области

Дата: Четверг, 31.08.2023, 07:07 | Сообщение № 1

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 0% ±

Доброго времени суток, друзья!
Прошу помочь с выполнением следующей задачи через макрос.
Имеется огромное количество (более ста) файлов (я для примера поместил два в папку "Рабочая книга"), в которые необходимо в одинаковую область, в моем примере P13:Q17 вставить текст и изображения из аналогичной области исходной книги "изображения". Сделать это вручную можно, но во-первых долго, во-вторых с течением времени количество строк диапазона и содержание данного диапазона будут менять.
Можно ли сделать замену через макрос, чтобы, например, при выполнении макроса весь текст диапазона P13:Q1000 автоматически заменял изображения и текст во всех книгах, которые лежат в папке.
Файлы во вложении.
Заранее благодарю за помощь!

К сообщению приложен файл: primer.rar (58.1 Kb)

Дата: Четверг, 31.08.2023, 12:02 | Сообщение № 2

Группа: Проверенные

Ранг: Обитатель

Сообщений: 318

Репутация: 64 ±

Замечаний: 0% ±

Excel LTSC 2021 EN

cyraxs, Доброго времени суток. Как вариант.
[vba]

Код

Option Explicit

Sub ЭкспортДанных()
    Dim Shape As Shape, SourceShape As Shape
    Dim FolderPath  As String: FolderPath = ThisWorkbook.Path & "\Рабочая книга" & "\"
    Dim SourceWS    As Worksheet: Set SourceWS = ThisWorkbook.Worksheets("Лист1")
    Dim sRow        As Long: sRow = SourceWS.Cells(SourceWS.Rows.Count, "P").End(xlUp).Row
    Dim SourceRange As Range: Set SourceRange = SourceWS.Range("P13:Q" & sRow)       ' Измените область по своему усмотрению
    Dim FileName    As String: FileName = Dir(FolderPath & "*.xls*")

    Do While FileName <> ""
        Application.ScreenUpdating = False
        Dim DestWB  As Workbook: Set DestWB = Workbooks.Open(FolderPath & FileName)
        Dim DestWS  As Worksheet: Set DestWS = DestWB.Worksheets("Лист1")
        Dim DestRange As Range: Set DestRange = DestWS.Range("P13:Q" & sRow)         ' Измените область по своему усмотрению

        For Each Shape In DestWS.Shapes
            Shape.Delete
        Next Shape

        SourceRange.Copy
        DestRange.PasteSpecial xlPasteAll
        Application.CutCopyMode = False

        For Each SourceShape In SourceWS.Shapes

            If SourceShape.TopLeftCell.Row >= SourceRange.Row And SourceShape.BottomRightCell.Row <= SourceRange.Row + SourceRange.Rows.Count - 1 Then
                Dim LeftPos As Single, TopPos As Single
                LeftPos = DestRange.Cells(1, 1).Left + SourceShape.Left - SourceRange.Cells(1, 1).Left
                TopPos = DestRange.Cells(1, 1).Top + SourceShape.Top - SourceRange.Cells(1, 1).Top
                SourceShape.CopyPicture xlScreen, xlBitmap
                DestWS.Paste Destination:=DestWS.Cells(DestRange.Cells(1, 1).Row, DestRange.Cells(1, 1).Column)

                With DestWS.Shapes(DestWS.Shapes.Count)
                    .Left = LeftPos
                    .Top = TopPos
                End With

            End If

        Next SourceShape

        Application.DisplayAlerts = False
        DestWB.Close SaveChanges:=True
        Application.DisplayAlerts = True
        FileName = Dir
        Application.ScreenUpdating = True
    Loop

    MsgBox "Экспорт Данных завершен! "
End Sub

[/vba]
Удачи.

cyraxs, Доброго времени суток. Как вариант.
[vba]

Код

[/vba]
Удачи.MikeVol

Ученик.

Сообщениеcyraxs, Доброго времени суток. Как вариант.
[vba]

Код

[/vba]
Удачи.

Автор - MikeVol
Дата добавления - 31.08.2023 в 12:02

Дата: Четверг, 31.08.2023, 15:22 | Сообщение № 3

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 0% ±

MikeVol, то что нужно!!
Только есть один нюанс который я не учел сначала. Наименование самого листа в моих изначальных файлах "лист1", а фактически имена другие. Можно скорректировать макрос, чтоб он работал для всех листов всех файлов в папке, не зависимо от имени листа?

Дата: Четверг, 31.08.2023, 15:37 | Сообщение № 4

Группа: Проверенные

Ранг: Обитатель

Сообщений: 318

Репутация: 64 ±

Замечаний: 0% ±

Excel LTSC 2021 EN

cyraxs, В следуйщий раз соберите свою хотелку в одно понятное предложение!
[vba]

Код

Option Explicit

Sub ЭкспортДанныхВоВсеЛисты()
    Dim DestWS      As Worksheet
    Dim Shape As Shape, SourceShape As Shape
    Dim FolderPath  As String: FolderPath = ThisWorkbook.Path & "\Рабочая книга" & "\"
    Dim SourceWS    As Worksheet: Set SourceWS = ThisWorkbook.Worksheets("Лист1")
    Dim sRow        As Long: sRow = SourceWS.Cells(SourceWS.Rows.Count, "P").End(xlUp).Row
    Dim SourceRange As Range: Set SourceRange = SourceWS.Range("P13:Q" & sRow)
    Dim FileName    As String: FileName = Dir(FolderPath & "*.xls*")

    Do While FileName <> ""
        Application.ScreenUpdating = False
        Dim DestWB  As Workbook: Set DestWB = Workbooks.Open(FolderPath & FileName)

        ' Перебераем все листы в Книгах приёмкниках
        For Each DestWS In DestWB.Worksheets
            Dim DestRange As Range: Set DestRange = DestWS.Range("P13:Q" & sRow)

            For Each Shape In DestWS.Shapes
                Shape.Delete
            Next Shape

            SourceRange.Copy
            DestRange.PasteSpecial xlPasteAll
            Application.CutCopyMode = False

            For Each SourceShape In SourceWS.Shapes

                If SourceShape.TopLeftCell.Row >= SourceRange.Row And SourceShape.BottomRightCell.Row <= SourceRange.Row + SourceRange.Rows.Count - 1 Then
                    Dim LeftPos As Single, TopPos As Single
                    LeftPos = DestRange.Cells(1, 1).Left + SourceShape.Left - SourceRange.Cells(1, 1).Left
                    TopPos = DestRange.Cells(1, 1).Top + SourceShape.Top - SourceRange.Cells(1, 1).Top
                    SourceShape.CopyPicture xlScreen, xlBitmap
                    DestWS.Paste Destination:=DestWS.Cells(DestRange.Cells(1, 1).Row, DestRange.Cells(1, 1).Column)

                    With DestWS.Shapes(DestWS.Shapes.Count)
                        .Left = LeftPos
                        .Top = TopPos
                    End With

                End If

            Next SourceShape

        Next DestWS

        Application.DisplayAlerts = False
        DestWB.Close SaveChanges:=True
        Application.DisplayAlerts = True
        FileName = Dir
        Application.ScreenUpdating = True
    Loop

    MsgBox "Экспорт Данных завершен!"
End Sub

[/vba]

cyraxs, В следуйщий раз соберите свою хотелку в одно понятное предложение!
[vba]

Код

[/vba]MikeVol

Ученик.

Сообщениеcyraxs, В следуйщий раз соберите свою хотелку в одно понятное предложение!
[vba]

Код

[/vba]

Автор - MikeVol
Дата добавления - 31.08.2023 в 15:37

Дата: Четверг, 31.08.2023, 15:48 | Сообщение № 5

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 0% ±

MikeVol, учту это.
Большое спасибо!!!

Дата: Четверг, 31.08.2023, 17:43 | Сообщение № 6

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 0% ±

MikeVol, прошу прощения, но не решился вопрос...
Во всех вложениях, оказывается, картинки в формате wmf, а не jpeg, а макрос переносит в картинки растровые, а не векторные.

Дата: Четверг, 31.08.2023, 20:29 | Сообщение № 7

Группа: Проверенные

Ранг: Обитатель

Сообщений: 318

Репутация: 64 ±

Замечаний: 0% ±

Excel LTSC 2021 EN

cyraxs, Найдите эту строку:
[vba]

Код

SourceShape.CopyPicture xlScreen, xlBitmap

[/vba]
и замените на вот эту:
[vba]

Код

SourceShape.Copy

[/vba]

Ученик.

Дата: Пятница, 01.09.2023, 07:41 | Сообщение № 8

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 0% ±

MikeVol, Благодарю!

Дата: Пятница, 29.09.2023, 12:14 | Сообщение № 9

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 0% ±

MikeVol, Добрый день!
Еще раз благодарю за помощь, но сегодня в работе макроса была обнаружена несостыковка.
При его выполнении происходит "уничтожение" всех картинок к применяемым листам, которые находятся вне диапазона P13:Q.
А необходима замена изображения только к диапазону P13:Q.
Возможно поправить макрос?

Дата: Пятница, 29.09.2023, 20:44 | Сообщение № 10

Группа: Проверенные

Ранг: Обитатель

Сообщений: 318

Репутация: 64 ±

Замечаний: 0% ±

Excel LTSC 2021 EN

cyraxs, Доброго времени суток. Найдите в коде данный блок: [vba]

Код

            For Each Shape In DestWS.Shapes
                Shape.Delete
            Next Shape

[/vba]
и замените его на вот такой блок: [vba]

Код

            For Each Shape In DestWS.Shapes

                If Not Intersect(Shape.TopLeftCell, DestWS.Range("P13:Q" & sRow)) Is Nothing Then
                    Shape.Delete
                End If

            Next Shape

[/vba]
Это спасёт ваши остальные объекты на листах. Удачи.

Ученик.