Страницы: 1
RSS
Перенос данных с карт в табличку
 
Привет! столкнулся с задачей ... которую сам не могу решить ...
В общем ... есть карты (формы) в которых указываю данные людей ... потом эти данные нужно перенести в табличку ...
карты находятся на отдельном листе (название КАРТЫ) ... табличка также ... (название ТАБЛИЧКА)
первую карту я без проблем переношу данные в табличку, но другая карта находится на следующей странице листа КАРТЫ ....
не могу понять как скопировать данные новой карты в следующую строку .... прошу помощи ...
предоставляю свой документ ... (документ на укр)
 
Цитата
не могу понять как скопировать данные новой карты в следующую строку
На листе Карти ищите все строки с Загальна інформація и относительно этой строки  переносите в умную Таблицу значения
Код
Sub FindЗагальна()
Dim FoundCell As Range
Dim FAdr As String
  With Worksheets("Карти")
     Set FoundCell = .Columns("A:R").Find("Загальна інформація", , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
       FAdr = FoundCell.Address     'нашли первое вхождение
       Do
         'относительно строки с FoundCell.Address переносите в умную Таблицу значения
         'cells(FoundCell.Row+1,"C") - это П.І.Б.:
         'и т.д.
         Set FoundCell = .Columns("A:R").FindNext(FoundCell)
       Loop While FoundCell.Address <> FAdr
     End If
  End With
End Sub

Про умные таблицы почитайте
https://www.thespreadsheetguru.com/blog/2014/6/20/the-vba-guide-to-listobject-excel-tables
 
спасибо за ответ... но чет я далек от этих макросов... уже час сижу.. и вот вникнуть никак....
то что я нашел через поиск диапазон строк с "Загальна інформація" ... но как ето применить дальше.. далек
спасибо всем за ответ... иду еще посижу...  
 
При активном листе Таблиця, макрос в стандартный модуль
Код
Sub FindЗагальна()
Dim FoundCell As Range
Dim FAdr As String
Dim tbl As ListObject
Dim n As Long
  With Worksheets("Карти")
    'удаление умной таблицы, кроме первой строки
    Set tbl = ActiveSheet.ListObjects("Таблица2")
       With tbl.DataBodyRange
        If .Rows.Count > 1 Then
          .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
        End If
       End With
       'очистка данных первой строки
       tbl.DataBodyRange.Rows(1).ClearContents
     Set FoundCell = .Columns("A:R").Find("Загальна інформація", , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
       FAdr = FoundCell.Address     'нашли первое вхождение
       n = 1
       Do
         tbl.ListRows.Add 'для 2003 AlwaysInsert:=True    'добавляем строку в таблицу
         tbl.DataBodyRange(n, 1) = n
         tbl.DataBodyRange(n, 2) = .Cells(FoundCell.Row + 1, "C")     'П.І.Б.:
            'все остальные строки добавьте сами
         tbl.DataBodyRange(n, 32) = .Cells(FoundCell.Row + 37, "N")     '
         Set FoundCell = .Columns("A:R").FindNext(FoundCell)
         n = n + 1
       Loop While FoundCell.Address <> FAdr
     End If
  End With
End Sub
 
Kuzmich, спасибо))) не знаю как и благодарить....)) иду дальше добавлять данние)))
тему можно закривать
Страницы: 1
Наверх