Страницы: 1
RSS
Выбор диапазона ячеек по меткам
 
Столкнулся с задачей выгрузки с листа расчетов в отдельные PDF файлы.
Как экспортировать понятно, но как выделить скриптом необходимый диапазон по меткам, не могу разобраться.
Нужно именно по меткам, т.к. в диапазоне могут добавляться новые строки и экспортируется только необходимая область
Файл для примера приложил.
Скрытый текст


Так начались мои мытарства....
Код
For Each cell In ActiveSheet.UsedRange.Columns(1).Cells
If cell.Value = "x" Then ..... дальше не знаю (

Если рассматривать на примере, хочется чтобы макрос последовательно выбирал по меткам
"содержимое A", потом экспорт
"содержимое B", потом экспорт
"содержимое C", потом экспорт

и т.д.

Помогите пожалуйста!
Я только учусь
 
Вариант без доп. проверок:
Код
Sub Macro1()
Dim LastRow As Long, i As Long, Rng As Range, Cell_1 As Range, Cell_2 As Range
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 1 To LastRow
        If Cells(i, 1) <> "" Then
            Set Cell_1 = Cells(i, 1).Offset(1, 1)
            Set Rng = Columns(12).Find(what:=Cells(i, 1), LookIn:=xlValues, LookAt:=xlWhole)
            If Not Rng Is Nothing Then Set Cell_2 = Rng.Offset(-1, -1)
            MsgBox "Диапазон имеет адреса: " & Cell_1.Address(0, 0) & ":" & Cell_2.Address(0, 0), 64, "Для сведения."
        End If
    Next
End Sub
 
Еще вариант
Код
Sub ExportArea()
arrMaker = Array("a", "b", "c")
On Error Resume Next
With ActiveSheet.UsedRange
    For I = 0 To UBound(arrMaker)
        Set iCell = .Find(arrMaker(I))
        If Not iCell Is Nothing Then
            fAddress = iCell.Address
            Do
                sAddress = iCell.Address
                Set iCell = .FindNext(iCell)
            Loop While Not iCell Is Nothing And iCell.Address <> fAddress
        End If
        .Range(fAddress, sAddress).Select
        MsgBox "Выбран диапазон: " & .Range(fAddress, sAddress).Address
    Next
End With
End Sub
Согласие есть продукт при полном непротивлении сторон
 
Юрий М, спасибо за ваш вариант!
Sanja, спасибо за наглядный пример, понравилось!
Очень помогли! Буду дорабатывать
Я только учусь
 
spacemakerman, в моем коде, для корректной работы, крайне желательно, что бы пара маркеров была уникальна и маркеры не попадались в содержимом Содержимого
Согласие есть продукт при полном непротивлении сторон
 
Добрый день!
Спасибо больше еще раз за предложенное решение.
Но сейчас столкнулся с проблемой - и не могу понять как сделать что бы срабатывало на разных листах

эти варианты не работают (
Код
With Sheets("diagram").Activate.UsedRange
With Sheets("diagram").UsedRange
With ActiveSheet("diagram").Activate.UsedRange
Я только учусь
 
Цитата
spacemakerman написал: With Sheets("diagram").UsedRange
Вот этот вариант должен работать. Если структура листа 'diagram' такая же как в примере. См.файл
Изменено: Sanja - 17.02.2018 15:43:26
Согласие есть продукт при полном непротивлении сторон
 
Sanja, спасибо )

скорей так
Код
Sub ExportArea()
Sheets("diagram").Activate
arrMaker = Array("a", "b", "c")
On Error Resume Next
With ActiveSheet.UsedRange
    For I = 0 To UBound(arrMaker)
        Set iCell = .Find(arrMaker(I))
        If Not iCell Is Nothing Then
            fAddress = iCell.Address
            Do
                sAddress = iCell.Address
                Set iCell = .FindNext(iCell)
            Loop While Not iCell Is Nothing And iCell.Address <> fAddress
        End If
        .Range(fAddress, sAddress).Select
        MsgBox "Выбран диапазон: " & .Range(fAddress, sAddress).Address
        
    Next
Sheets("diagram2").Activate
arrMaker = Array("a", "b", "c")
On Error Resume Next
With ActiveSheet.UsedRange
    For I = 0 To UBound(arrMaker)
        Set iCell = .Find(arrMaker(I))
        If Not iCell Is Nothing Then
            fAddress = iCell.Address
            Do
                sAddress = iCell.Address
                Set iCell = .FindNext(iCell)
            Loop While Not iCell Is Nothing And iCell.Address <> fAddress
        End If
        .Range(fAddress, sAddress).Select
        MsgBox "Выбран диапазон: " & .Range(fAddress, sAddress).Address
    Next
End With
End With
End Sub
Изменено: spacemakerman - 17.02.2018 18:15:31 (убрал лишние строки "objBook.Visible = True" обновил вложения)
Я только учусь
 
Цитата
spacemakerman написал: скорей так
Тогда уж лучше так. Будут перебираться листы, имя которых начинается на 'diagram'. И вопрос в Коде прокомментируйте. Зачем там эта строка?
Код
Sub ExportArea()
Dim iSh As Worksheet, arrMaker(), I&, iCell As Range
Dim fAddress$, sAddress$
arrMaker = Array("a", "b", "c")
On Error Resume Next
objBook.Visible = True  'вот эта строка к чему? Что такое 'objBook'
For Each iSh In Worksheets
    If iSh.Name Like "diagram*" Then
        With iSh.UsedRange
            For I = 0 To UBound(arrMaker)
                Set iCell = .Find(arrMaker(I))
                If Not iCell Is Nothing Then
                    fAddress = iCell.Address
                    Do
                        sAddress = iCell.Address
                        Set iCell = .FindNext(iCell)
                    Loop While Not iCell Is Nothing And iCell.Address <> fAddress
                End If
                iSh.Activate
                .Range(fAddress, sAddress).Select
                MsgBox "Выбран диапазон: " & .Range(fAddress, sAddress).Address
            Next
        End With
    End If
Next
End Sub
Изменено: Sanja - 17.02.2018 18:01:46
Согласие есть продукт при полном непротивлении сторон
 
Цитата
Sanja написал: Тогда уж лучше так. Будут перебираться листы, имя которых начинается на 'diagram'.
Да так намного оптимальнее, но я еще не умею так делать :)
А если у листов разные названия?

Цитата
Sanja написал: И вопрос в Коде прокомментируйте. Зачем там эта строка?
это следы моих эксперементов, прошу прощения, забыл убрать (код поправил)
Изменено: spacemakerman - 17.02.2018 18:20:16
Я только учусь
 
Цитата
spacemakerman написал: А если у листов разные названия?
Ну варианты могут быть разные. Если имена нужных листов заранее известны, внесите их в массив и перебирайте его. Если НЕизвестны, но известны имена листов, которые НЕ должны попасть в перебор, то проверяйте все имена и не нужные исключайте из перебора. Ну и т.п.
Согласие есть продукт при полном непротивлении сторон
Страницы: 1
Наверх