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

Вход

Регистрация

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

 

= Мир MS Excel/VBA поиск и копирование информации по условию - Мир MS Excel

  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
VBA поиск и копирование информации по условию
zaknafein Дата: Вторник, 25.03.2025, 09:27 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Здравствуйте, уважаемы форумчане! Помогите, пожалуйста, решить задачку. есть два файла 1 и 2(прикладываю). нужно из файла 1 запустить скрипт, который откроет в фоне второй файл, по полю ID найдет совпадение и скопирует данные из второго в первый в соответствующие столбцы. Так же есть нюанс, если в поле второго файла в поле title3 написано 456 то необходимо искать и копировать инфу на лист один первого файла. а если что то другое в поле то на лист 2. спасибо за помощь.
К сообщению приложен файл: 0520106.xlsx (8.0 Kb) · 4571278.xlsx (8.9 Kb)
 
Ответить
СообщениеЗдравствуйте, уважаемы форумчане! Помогите, пожалуйста, решить задачку. есть два файла 1 и 2(прикладываю). нужно из файла 1 запустить скрипт, который откроет в фоне второй файл, по полю ID найдет совпадение и скопирует данные из второго в первый в соответствующие столбцы. Так же есть нюанс, если в поле второго файла в поле title3 написано 456 то необходимо искать и копировать инфу на лист один первого файла. а если что то другое в поле то на лист 2. спасибо за помощь.

Автор - zaknafein
Дата добавления - 25.03.2025 в 09:27
MikeVol Дата: Вторник, 25.03.2025, 20:19 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 423
Репутация: 92 ±
Замечаний: 0% ±

MSO LTSC 2021 EN
zaknafein, Следуйщий код внесите в
файла 1 запустить скрипт

Уажите свой путь ко второму файлу , читайте комментарии в коде. И запускаете макрос, будет вам счастье. [vba]
Код
Option Explicit

Sub CopyData_zaknafein()
    Dim wbB         As Workbook
    Dim cell        As Range

    Dim fileBPath   As String
    fileBPath = ThisWorkbook.Path & "\" & "0520106.xlsx"    ' Измените на фактический путь ко второму файлу

    Dim wsA1        As Worksheet
    Set wsA1 = ThisWorkbook.Worksheets("Лист1")

    Dim wsA2        As Worksheet
    Set wsA2 = ThisWorkbook.Worksheets("Лист2")

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual

        On Error Resume Next
        Set wbB = Workbooks.Open(fileBPath, ReadOnly:=True)
        On Error GoTo 0
        If wbB Is Nothing Then MsgBox "Не удалось открыть файл!", vbExclamation: Exit Sub

        Dim wsB     As Worksheet
        Set wsB = wbB.Worksheets(1)

        For Each cell In wsA1.Range("A2:A" & wsA1.Cells(Rows.Count, 1).End(xlUp).Row)
            Dim foundCell As Range
            Set foundCell = wsB.Range("A:A").Find(cell.Value, LookAt:=xlWhole)

            If Not foundCell Is Nothing Then
                Dim targetSheet As Worksheet
                Set targetSheet = IIf(foundCell.Offset(0, 3).Value = 456, wsA1, wsA2)
                targetSheet.Cells(cell.Row, 1).Resize(1, 4).Value = foundCell.Resize(1, 4).Value
            End If

        Next cell

        wbB.Close False

        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

End Sub
[/vba]Удачи.


Ученик.
Одесса - Украина
 
Ответить
Сообщениеzaknafein, Следуйщий код внесите в
файла 1 запустить скрипт

Уажите свой путь ко второму файлу , читайте комментарии в коде. И запускаете макрос, будет вам счастье. [vba]
Код
Option Explicit

Sub CopyData_zaknafein()
    Dim wbB         As Workbook
    Dim cell        As Range

    Dim fileBPath   As String
    fileBPath = ThisWorkbook.Path & "\" & "0520106.xlsx"    ' Измените на фактический путь ко второму файлу

    Dim wsA1        As Worksheet
    Set wsA1 = ThisWorkbook.Worksheets("Лист1")

    Dim wsA2        As Worksheet
    Set wsA2 = ThisWorkbook.Worksheets("Лист2")

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual

        On Error Resume Next
        Set wbB = Workbooks.Open(fileBPath, ReadOnly:=True)
        On Error GoTo 0
        If wbB Is Nothing Then MsgBox "Не удалось открыть файл!", vbExclamation: Exit Sub

        Dim wsB     As Worksheet
        Set wsB = wbB.Worksheets(1)

        For Each cell In wsA1.Range("A2:A" & wsA1.Cells(Rows.Count, 1).End(xlUp).Row)
            Dim foundCell As Range
            Set foundCell = wsB.Range("A:A").Find(cell.Value, LookAt:=xlWhole)

            If Not foundCell Is Nothing Then
                Dim targetSheet As Worksheet
                Set targetSheet = IIf(foundCell.Offset(0, 3).Value = 456, wsA1, wsA2)
                targetSheet.Cells(cell.Row, 1).Resize(1, 4).Value = foundCell.Resize(1, 4).Value
            End If

        Next cell

        wbB.Close False

        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

End Sub
[/vba]Удачи.

Автор - MikeVol
Дата добавления - 25.03.2025 в 20:19
MikeVol Дата: Воскресенье, 30.03.2025, 00:12 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 423
Репутация: 92 ±
Замечаний: 0% ±

MSO LTSC 2021 EN
zaknafein, Приветсвую. Так что там, решился ваш вопрос? Или в следуйщий раз Не Стоит Обращать внимание на ваши темы?


Ученик.
Одесса - Украина
 
Ответить
Сообщениеzaknafein, Приветсвую. Так что там, решился ваш вопрос? Или в следуйщий раз Не Стоит Обращать внимание на ваши темы?

Автор - MikeVol
Дата добавления - 30.03.2025 в 00:12
  • Страница 1 из 1
  • 1
Поиск:

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