Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Замена текста и изображения определенной области - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Замена текста и изображения определенной области (Макросы/Sub)
Замена текста и изображения определенной области
cyraxs Дата: Четверг, 31.08.2023, 07:07 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 20
Репутация: 0 ±
Замечаний: 0% ±

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

Автор - cyraxs
Дата добавления - 31.08.2023 в 07:07
MikeVol Дата: Четверг, 31.08.2023, 12:02 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 291
Репутация: 51 ±
Замечаний: 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]
Код
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]
Удачи.

Автор - MikeVol
Дата добавления - 31.08.2023 в 12:02
cyraxs Дата: Четверг, 31.08.2023, 15:22 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 20
Репутация: 0 ±
Замечаний: 0% ±

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

Автор - cyraxs
Дата добавления - 31.08.2023 в 15:22
MikeVol Дата: Четверг, 31.08.2023, 15:37 | Сообщение № 4
Группа: Проверенные
Ранг: Обитатель
Сообщений: 291
Репутация: 51 ±
Замечаний: 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]
Код
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]

Автор - MikeVol
Дата добавления - 31.08.2023 в 15:37
cyraxs Дата: Четверг, 31.08.2023, 15:48 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 20
Репутация: 0 ±
Замечаний: 0% ±

MikeVol, учту это.
Большое спасибо!!!
 
Ответить
СообщениеMikeVol, учту это.
Большое спасибо!!!

Автор - cyraxs
Дата добавления - 31.08.2023 в 15:48
cyraxs Дата: Четверг, 31.08.2023, 17:43 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 20
Репутация: 0 ±
Замечаний: 0% ±

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

Автор - cyraxs
Дата добавления - 31.08.2023 в 17:43
MikeVol Дата: Четверг, 31.08.2023, 20:29 | Сообщение № 7
Группа: Проверенные
Ранг: Обитатель
Сообщений: 291
Репутация: 51 ±
Замечаний: 0% ±

Excel LTSC 2021 EN
cyraxs, Найдите эту строку:
[vba]
Код
                    SourceShape.CopyPicture xlScreen, xlBitmap
[/vba]
и замените на вот эту:
[vba]
Код
                    SourceShape.Copy
[/vba]


Ученик.
 
Ответить
Сообщениеcyraxs, Найдите эту строку:
[vba]
Код
                    SourceShape.CopyPicture xlScreen, xlBitmap
[/vba]
и замените на вот эту:
[vba]
Код
                    SourceShape.Copy
[/vba]

Автор - MikeVol
Дата добавления - 31.08.2023 в 20:29
cyraxs Дата: Пятница, 01.09.2023, 07:41 | Сообщение № 8
Группа: Пользователи
Ранг: Новичок
Сообщений: 20
Репутация: 0 ±
Замечаний: 0% ±

MikeVol, Благодарю!
 
Ответить
СообщениеMikeVol, Благодарю!

Автор - cyraxs
Дата добавления - 01.09.2023 в 07:41
cyraxs Дата: Пятница, 29.09.2023, 12:14 | Сообщение № 9
Группа: Пользователи
Ранг: Новичок
Сообщений: 20
Репутация: 0 ±
Замечаний: 0% ±

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

Автор - cyraxs
Дата добавления - 29.09.2023 в 12:14
MikeVol Дата: Пятница, 29.09.2023, 20:44 | Сообщение № 10
Группа: Проверенные
Ранг: Обитатель
Сообщений: 291
Репутация: 51 ±
Замечаний: 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]
Это спасёт ваши остальные объекты на листах. Удачи.


Ученик.
 
Ответить
Сообщение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]
Это спасёт ваши остальные объекты на листах. Удачи.

Автор - MikeVol
Дата добавления - 29.09.2023 в 20:44
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Замена текста и изображения определенной области (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!