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

Вход

Регистрация

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

 

= Мир MS Excel/Сбор данных с листов с фиксированным оглавлением - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сбор данных с листов с фиксированным оглавлением (Макросы/Sub)
Сбор данных с листов с фиксированным оглавлением
gge29 Дата: Суббота, 13.08.2022, 10:35 | Сообщение № 1
Группа: Проверенные
Ранг: Обитатель
Сообщений: 302
Репутация: 3 ±
Замечаний: 0% ±

День добрый!помогите пожалуйста допилить код
оглавление одно и тоже,брать только до итого(это работает)
но шапка тоже попадает в общую
файл пример прилагается как должно быть

[vba]
Код
Sub sborka2()
Dim sht As Worksheet
Dim I As Long, k As Long, j As Long
If MsgBox("Сборка производится на первый лист, правильно?", vbYesNo + vbDefaultButton2) = 6 Then
Sheets(1).Range("a1").CurrentRegion.Clear
Sheets(2).Cells(1, 1).Resize(, 2).Copy Sheets(1).Cells(1, 1)
    For Each sht In ActiveWorkbook.Worksheets
    i_n = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
        If sht.Index <> 1 Then
        I = 1
        Do
        I = I + 1
        Loop While sht.Cells(I, 1) <> "ИТОГО"
        sht.Cells(2, 1).Resize(I - 2, 4).Copy Worksheets(1).Cells(i_n + 1, 1)
        End If
    Next sht
End If
End Sub
[/vba]
К сообщению приложен файл: 5746409.xls (45.0 Kb)
 
Ответить
СообщениеДень добрый!помогите пожалуйста допилить код
оглавление одно и тоже,брать только до итого(это работает)
но шапка тоже попадает в общую
файл пример прилагается как должно быть

[vba]
Код
Sub sborka2()
Dim sht As Worksheet
Dim I As Long, k As Long, j As Long
If MsgBox("Сборка производится на первый лист, правильно?", vbYesNo + vbDefaultButton2) = 6 Then
Sheets(1).Range("a1").CurrentRegion.Clear
Sheets(2).Cells(1, 1).Resize(, 2).Copy Sheets(1).Cells(1, 1)
    For Each sht In ActiveWorkbook.Worksheets
    i_n = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
        If sht.Index <> 1 Then
        I = 1
        Do
        I = I + 1
        Loop While sht.Cells(I, 1) <> "ИТОГО"
        sht.Cells(2, 1).Resize(I - 2, 4).Copy Worksheets(1).Cells(i_n + 1, 1)
        End If
    Next sht
End If
End Sub
[/vba]
Автор - gge29
Дата добавления - 13.08.2022 в 10:35
Kuzmich Дата: Суббота, 13.08.2022, 15:05 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 713
Репутация: 157 ±
Замечаний: 0% ±

Excel 2003
Цитата
оглавление одно и тоже

Почему на листе 22 шапка начинается со второй строки?
 
Ответить
Сообщение
Цитата
оглавление одно и тоже

Почему на листе 22 шапка начинается со второй строки?
Автор - Kuzmich
Дата добавления - 13.08.2022 в 15:05
gge29 Дата: Суббота, 13.08.2022, 15:46 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 302
Репутация: 3 ±
Замечаний: 0% ±

Цитата Kuzmich, 13.08.2022 в 15:05, в сообщении № 2 ()
Почему на листе 22 шапка начинается со второй строки?

Согласен,мой косяк!
 
Ответить
Сообщение
Цитата Kuzmich, 13.08.2022 в 15:05, в сообщении № 2 ()
Почему на листе 22 шапка начинается со второй строки?

Согласен,мой косяк!
Автор - gge29
Дата добавления - 13.08.2022 в 15:46
Kuzmich Дата: Суббота, 13.08.2022, 15:56 | Сообщение № 4
Группа: Проверенные
Ранг: Ветеран
Сообщений: 713
Репутация: 157 ±
Замечаний: 0% ±

Excel 2003
На листе Свод строки с 6-ой и далее д.б. очищены
[vba]
Код
Sub Sborka()
Dim Sht As Worksheet
Dim iLastRow As Long
Dim FoundCell As Range
Dim Row_Itogo As Long
Dim dict As Object
  For Each Sht In Worksheets                            'цикл по всем листам
    If Sht.Name <> "Свод" Then
      With Sht
       Set FoundCell = .Columns("A").Find("ИТОГО", , xlValues, xlWhole)            'поиск слова ИТОГО
        If Not FoundCell Is Nothing Then
          Row_Itogo = FoundCell.Row
          iLastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
          .Range(.Cells(6, 1), .Cells(Row_Itogo - 1, "D")).Copy Cells(iLastRow, "A")
        End If
        Set FoundCell = Nothing
      End With
    End If
  Next
End Sub
[/vba]
И нет данных о: ниже могут содержаться дополнительные таблицы
 
Ответить
СообщениеНа листе Свод строки с 6-ой и далее д.б. очищены
[vba]
Код
Sub Sborka()
Dim Sht As Worksheet
Dim iLastRow As Long
Dim FoundCell As Range
Dim Row_Itogo As Long
Dim dict As Object
  For Each Sht In Worksheets                            'цикл по всем листам
    If Sht.Name <> "Свод" Then
      With Sht
       Set FoundCell = .Columns("A").Find("ИТОГО", , xlValues, xlWhole)            'поиск слова ИТОГО
        If Not FoundCell Is Nothing Then
          Row_Itogo = FoundCell.Row
          iLastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
          .Range(.Cells(6, 1), .Cells(Row_Itogo - 1, "D")).Copy Cells(iLastRow, "A")
        End If
        Set FoundCell = Nothing
      End With
    End If
  Next
End Sub
[/vba]
И нет данных о: ниже могут содержаться дополнительные таблицы
Автор - Kuzmich
Дата добавления - 13.08.2022 в 15:56
gge29 Дата: Суббота, 13.08.2022, 17:55 | Сообщение № 5
Группа: Проверенные
Ранг: Обитатель
Сообщений: 302
Репутация: 3 ±
Замечаний: 0% ±

Шапка отсутствует!ниже может быть что угодно.И после нажатия кнопки идёт повтор,а не чистка предыдущей
 
Ответить
СообщениеШапка отсутствует!ниже может быть что угодно.И после нажатия кнопки идёт повтор,а не чистка предыдущей
Автор - gge29
Дата добавления - 13.08.2022 в 17:55
Kuzmich Дата: Суббота, 13.08.2022, 22:49 | Сообщение № 6
Группа: Проверенные
Ранг: Ветеран
Сообщений: 713
Репутация: 157 ±
Замечаний: 0% ±

Excel 2003
Цитата
после нажатия кнопки идёт повтор,а не чистка предыдущей

Я вам написал, что
Цитата
На листе Свод строки с 6-ой и далее д.б. очищены

Это действие можно прописать в макросе
[vba]
Код
Sub Sborka()
Dim Sht As Worksheet
Dim iLastRow As Long
Dim FoundCell As Range
Dim Row_Itogo As Long
    iLastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
    Range("A6:D" & iLastRow).Clear
  For Each Sht In Worksheets                            'цикл по всем листам
    If Sht.Name <> "Свод" Then
      With Sht
       Set FoundCell = .Columns("A").Find("ИТОГО", , xlValues, xlWhole)            'поиск слова ИТОГО
        If Not FoundCell Is Nothing Then
          Row_Itogo = FoundCell.Row
          iLastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
          .Range(.Cells(6, 1), .Cells(Row_Itogo - 1, "D")).Copy Cells(iLastRow, "A")
        End If
        Set FoundCell = Nothing
      End With
    End If
  Next
End Sub
[/vba]
 
Ответить
Сообщение
Цитата
после нажатия кнопки идёт повтор,а не чистка предыдущей

Я вам написал, что
Цитата
На листе Свод строки с 6-ой и далее д.б. очищены

Это действие можно прописать в макросе
[vba]
Код
Sub Sborka()
Dim Sht As Worksheet
Dim iLastRow As Long
Dim FoundCell As Range
Dim Row_Itogo As Long
    iLastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
    Range("A6:D" & iLastRow).Clear
  For Each Sht In Worksheets                            'цикл по всем листам
    If Sht.Name <> "Свод" Then
      With Sht
       Set FoundCell = .Columns("A").Find("ИТОГО", , xlValues, xlWhole)            'поиск слова ИТОГО
        If Not FoundCell Is Nothing Then
          Row_Itogo = FoundCell.Row
          iLastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
          .Range(.Cells(6, 1), .Cells(Row_Itogo - 1, "D")).Copy Cells(iLastRow, "A")
        End If
        Set FoundCell = Nothing
      End With
    End If
  Next
End Sub
[/vba]
Автор - Kuzmich
Дата добавления - 13.08.2022 в 22:49
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сбор данных с листов с фиксированным оглавлением (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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