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

Вход

Регистрация

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

 

= Мир MS Excel/Перейти на сл лист если в диапазоне нет опред слов - Мир MS Excel

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

Избитая тема, но подскажите пожалуйста....
собираю данные с разных кник в одну и макросом Щербакова Дмитрия, как в него добавить в цикл по книгам и листам условие проверки- если в диапазоне Е1:Е50 нет фразы Локальная смета №, то переходить на следующий лист

[vba]
Код
Sub РАБОТЫ()
    Dim iBeginRange As Range, rCopy As Range, lCalc As Long, lCol As Long
    Dim oAwb As String, sCopyAddress As String, sSheetName As String
    Dim lLastRow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
    Dim wsSh As Worksheet, wsDataSheet As Worksheet, bPolyBooks As Boolean, avFiles
    Dim wbAct As Workbook
    Dim bPasteValues As Boolean, IsPasteSheetName As Boolean
    
    On Error Resume Next
    'Выбираем диапазон выборки с книг
    Set iBeginRange = Range("$A:$L") 'диапазон указывается нужный
    'Указываем имя листа
    sSheetName = "*"
    'вставлять только значения ячеек (без формул и форматов)
    bPasteValues = vbYes
    'Запрос сбора данных с книг(если Нет - то сбор идет с активной книги)
    If MsgBox("Собрать работы с нескольких книг?", vbInformation + vbYesNo) = vbYes Then
        avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True)
        If VarType(avFiles) = vbBoolean Then Exit Sub
        bPolyBooks = True
        lCol = 0
    Else
        avFiles = Array(ThisWorkbook.FullName)
    End If
    If IsPasteSheetName Then
        lCol = lCol + 1
    End If
    'отключаем обновление экрана, автопересчет формул и отслеживание событий
    With Application
        lCalc = .Calculation
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlManual
    End With
    'создаем новый лист в книге для сбора
    Set wsDataSheet = ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
    wsDataSheet.Name = "Сводная работ"
    'цикл по книгам
    For li = LBound(avFiles) To UBound(avFiles)
        If bPolyBooks Then
            Set wbAct = Workbooks.Open(Filename:=avFiles(li))
        Else
            Set wbAct = ThisWorkbook
        End If
        oAwb = wbAct.Name
        'цикл по листам
        For Each wsSh In wbAct.Sheets
            If wsSh.Name Like sSheetName Then
                If wsSh.Visible = -1 Then
                    'Если имя листа совпадает с именем листа, в который собираем данные
                    'и сбор идет только с активной книги - то переходим к следующему листу
                    If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_
                    With wsSh
                        Select Case iBeginRange.Count
                        Case 1 'собираем данные начиная с указанной ячейки и до конца данных
                            lLastRow = .Cells(1, 1).SpecialCells(xlLastCell).Row
                            iLastColumn = .Cells.SpecialCells(xlLastCell).Column
                            sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastRow, iLastColumn)).Address
                        Case Else 'собираем данные с фиксированного диапазона
                            sCopyAddress = iBeginRange.Address
                        End Select
                        lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1
                        'определяем для копирования диапазон только заполненных данных на листе
                        Set rCopy = Intersect(.Range(sCopyAddress).Parent.UsedRange, .Range(sCopyAddress))
                        'если вставляем только значения
                        rCopy.Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol)
                        'End If
                    End With
                End If
            End If
NEXT_:
        Next wsSh
        Application.CutCopyMode = False
        If bPolyBooks Then
            wbAct.Close False
        End If
    Next li
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = lCalc
    End With
    Application.CutCopyMode = True
  End Sub
[/vba]
 
Ответить
СообщениеИзбитая тема, но подскажите пожалуйста....
собираю данные с разных кник в одну и макросом Щербакова Дмитрия, как в него добавить в цикл по книгам и листам условие проверки- если в диапазоне Е1:Е50 нет фразы Локальная смета №, то переходить на следующий лист

[vba]
Код
Sub РАБОТЫ()
    Dim iBeginRange As Range, rCopy As Range, lCalc As Long, lCol As Long
    Dim oAwb As String, sCopyAddress As String, sSheetName As String
    Dim lLastRow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
    Dim wsSh As Worksheet, wsDataSheet As Worksheet, bPolyBooks As Boolean, avFiles
    Dim wbAct As Workbook
    Dim bPasteValues As Boolean, IsPasteSheetName As Boolean
    
    On Error Resume Next
    'Выбираем диапазон выборки с книг
    Set iBeginRange = Range("$A:$L") 'диапазон указывается нужный
    'Указываем имя листа
    sSheetName = "*"
    'вставлять только значения ячеек (без формул и форматов)
    bPasteValues = vbYes
    'Запрос сбора данных с книг(если Нет - то сбор идет с активной книги)
    If MsgBox("Собрать работы с нескольких книг?", vbInformation + vbYesNo) = vbYes Then
        avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True)
        If VarType(avFiles) = vbBoolean Then Exit Sub
        bPolyBooks = True
        lCol = 0
    Else
        avFiles = Array(ThisWorkbook.FullName)
    End If
    If IsPasteSheetName Then
        lCol = lCol + 1
    End If
    'отключаем обновление экрана, автопересчет формул и отслеживание событий
    With Application
        lCalc = .Calculation
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlManual
    End With
    'создаем новый лист в книге для сбора
    Set wsDataSheet = ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
    wsDataSheet.Name = "Сводная работ"
    'цикл по книгам
    For li = LBound(avFiles) To UBound(avFiles)
        If bPolyBooks Then
            Set wbAct = Workbooks.Open(Filename:=avFiles(li))
        Else
            Set wbAct = ThisWorkbook
        End If
        oAwb = wbAct.Name
        'цикл по листам
        For Each wsSh In wbAct.Sheets
            If wsSh.Name Like sSheetName Then
                If wsSh.Visible = -1 Then
                    'Если имя листа совпадает с именем листа, в который собираем данные
                    'и сбор идет только с активной книги - то переходим к следующему листу
                    If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_
                    With wsSh
                        Select Case iBeginRange.Count
                        Case 1 'собираем данные начиная с указанной ячейки и до конца данных
                            lLastRow = .Cells(1, 1).SpecialCells(xlLastCell).Row
                            iLastColumn = .Cells.SpecialCells(xlLastCell).Column
                            sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastRow, iLastColumn)).Address
                        Case Else 'собираем данные с фиксированного диапазона
                            sCopyAddress = iBeginRange.Address
                        End Select
                        lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1
                        'определяем для копирования диапазон только заполненных данных на листе
                        Set rCopy = Intersect(.Range(sCopyAddress).Parent.UsedRange, .Range(sCopyAddress))
                        'если вставляем только значения
                        rCopy.Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol)
                        'End If
                    End With
                End If
            End If
NEXT_:
        Next wsSh
        Application.CutCopyMode = False
        If bPolyBooks Then
            wbAct.Close False
        End If
    Next li
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = lCalc
    End With
    Application.CutCopyMode = True
  End Sub
[/vba]

Автор - Gjlhzl
Дата добавления - 06.12.2023 в 20:37
Gjlhzl Дата: Среда, 06.12.2023, 20:38 | Сообщение № 2
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 110
Репутация: 0 ±
Замечаний: 0% ±


Подозреваю куда то сюда нужно воткнуть...
[vba]
Код
If Range("E1:E50") <> "ЛОКАЛЬНАЯ СМЕТА №" Then
[/vba]


[vba]
Код
   'цикл по листам
        For Each wsSh In wbAct.Sheets
            If wsSh.Name Like sSheetName Then
                If wsSh.Visible = -1 Then
                    'Если имя листа совпадает с именем листа, в который собираем данные
                    'и сбор идет только с активной книги - то переходим к следующему листу
                    If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_
                    With wsSh
[/vba]
 
Ответить
Сообщение
Подозреваю куда то сюда нужно воткнуть...
[vba]
Код
If Range("E1:E50") <> "ЛОКАЛЬНАЯ СМЕТА №" Then
[/vba]


[vba]
Код
   'цикл по листам
        For Each wsSh In wbAct.Sheets
            If wsSh.Name Like sSheetName Then
                If wsSh.Visible = -1 Then
                    'Если имя листа совпадает с именем листа, в который собираем данные
                    'и сбор идет только с активной книги - то переходим к следующему листу
                    If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_
                    With wsSh
[/vba]

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

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