Страницы: 1
RSS
Перенос данных из одной таблицы в другую по названию столбцов
 
Доброго времени суток. Подскажите пожалуйста как можно оптимизировать макрос? Изучаю vba недавно и не знаю всех тонкостей.
Сейчас макрос работает корректно и все обновляет, но если добавить листы то происходит ошибка. Как я понял нужно убрать цикличность и как то указать лист источник и лист куда вставляем (с чем сравниваем)
Код
Sub CopyData()
              
                
        Dim wbkX As Workbook                        'книга
        Dim shtSv As Worksheet, shtX As Worksheet   'листы
        Dim rngSv As Range, rngX As Range           'диапазоны
  
        Dim NrowSv As Long, NrowX As Long           'число строк
        Dim NcolSv As Integer, NcolX As Integer     'число столбцов

        Dim TitleSv, TitleX         '"будущие" массивы заголовков
        Dim i As Long, j As Long    'счетчики циклов

        Dim rngCopy As Range, rngPaste As Range     'что копировать и куда вставить


            Set wbkX = ThisWorkbook
  
  '= 1 == для листа "лист1" ======================
  Set shtSv = wbkX.Worksheets("Лист1")
  Set rngSv = shtSv.Range("A1").CurrentRegion
  NrowSv = rngSv.Rows.Count
  NcolSv = rngSv.Columns.Count
  TitleSv = rngSv.Rows(1)
  
  '= 2 == Цикл по всем листам, кроме "Лист1" ======================
  For Each shtX In wbkX.Worksheets
    Select Case shtX.Name
      Case "Лист1"   'для листа "реестр" - ничего не делаем!
      Case Else       '-- 3 -- для прочих листов ---------
        Set rngX = shtX.Range("A1").CurrentRegion
        NrowX = rngX.Rows.Count
        NcolX = rngX.Columns.Count
        TitleX = rngX.Rows(1)
        '-- 4 -- поиск совпадающих заголовков ---------
        For i = 1 To NcolSv
          For j = 1 To NcolX
            '-- 5 -- если заголовки совпали, то ...
            If TitleSv(1, i) = TitleX(1, j) Then
  '- 6 - что копировать ----
  Set rngCopy = Range(rngX.Cells(2, j), rngX.Cells(NrowX, j))
  '- 7 - куда вставить  ----
  Set rngPaste = rngSv.Cells(1 + 1, i).Resize(NrowX - 1, 1)
  '- 8 - копирование через буфер обмена -----
     rngCopy.Copy
     rngPaste.PasteSpecial
             End If
          Next j
        Next i
        '-- 9 -- определить новые размеры диапазона на листе "Лист1"  ---
        Set rngSv = shtSv.Range("A1").CurrentRegion
        NrowSv = rngSv.Rows.Count
    End Select
  Next shtX   '== конец цикла по листам ========================================
                
End Sub
Изменено: vikttur - 14.09.2021 13:05:01
 
PMO87, вы бы лучше описали что делает Ваш макрос с файлом примером где исходные данные и рядом или на другом листе желаемый результат. С файлом проще помогать
Изменено: Mershik - 14.09.2021 11:50:49
Не бойтесь совершенства. Вам его не достичь.
 
Доброго.
С листа читая макрос не вижу почему добавка листов может вызывать ошибку (кстати, какую, как выглядит ошибка?)
Вот эти инструкции:
Код
     rngCopy.Copy
     rngPaste.PasteSpecial

Зачем PasteSpecial? Вы хотите вставить что-то конкретное (значение, формат, формулу)? Тогда почему после PasteSpecial не указано что именно хотите вставить?
Если просто вставить, то достаточно
Код
rngCopy.Copy rngPaste


Поддерживаю вышесказанное - с файлом-примером было бы легче понимать задачу.
Изменено: Пытливый - 14.09.2021 12:18:30
Кому решение нужно - тот пример и рисует.
 
Цитата
Пытливый написал:
почему добавка листов может вызывать ошибку
Если первая строка пустая, то ошибка будет тут TitleSv(1, i).
 
Загрузил файл при + скрин ошибки если запускаешь макрос с новыми листами.

Смысл такой что есть - таблицы источник (множество столбцов) и таблица Получатель куда копируются данные с N столбцами.
Задачи автоматически обновлять данные  в таблицу Получатель из таблицы Источник по столбцам шапки не зависимо в каком месте они находятся на листе.

Т.е. сейчас ошибка при добавлении листа и если шапка таблицы Источник находится не на первой строке
Страницы: 1
Наверх