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

Вход

Регистрация

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

 

= Мир MS Excel/Отбор и перенос данных в умных таблицах - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Отбор и перенос данных в умных таблицах (Макросы/Sub)
Отбор и перенос данных в умных таблицах
AVI Дата: Пятница, 24.08.2018, 13:57 | Сообщение № 1
Группа: Проверенные
Ранг: Обитатель
Сообщений: 394
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
Очередной затык.
Кодне выдает ошибок - это уже хорошо, но не работает...

[vba]
Код
Sub ЙЙЙЙ()
   Dim ar, ak, i, j
    ar = Range("первая")
    ak = Range("вторая")
    For i = 1 To UBound(ar)
        For j = 1 To UBound(ak)
            If ar(i, 2) = ak(j, 1) Then
                If ar(i, 3) = "Да" Then
                    If ar(i, 4) > 20 Then
                        ar(i, 1) = ak(j, 2)
                        Exit For
                    End If
                End If
            End If
        Next j
    Next i
End Sub
[/vba]
К сообщению приложен файл: 4799794.xlsm(16.2 Kb)
 
Ответить
СообщениеОчередной затык.
Кодне выдает ошибок - это уже хорошо, но не работает...

[vba]
Код
Sub ЙЙЙЙ()
   Dim ar, ak, i, j
    ar = Range("первая")
    ak = Range("вторая")
    For i = 1 To UBound(ar)
        For j = 1 To UBound(ak)
            If ar(i, 2) = ak(j, 1) Then
                If ar(i, 3) = "Да" Then
                    If ar(i, 4) > 20 Then
                        ar(i, 1) = ak(j, 2)
                        Exit For
                    End If
                End If
            End If
        Next j
    Next i
End Sub
[/vba]

Автор - AVI
Дата добавления - 24.08.2018 в 13:57
_Boroda_ Дата: Пятница, 24.08.2018, 14:06 | Сообщение № 2
Группа: Модераторы
Ранг: Местный житель
Сообщений: 12958
Репутация: 5330 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Вам нужно заполнить вторую таблицу датами из первой?
Тогда

[vba]
Код
Sub ЙЙЙЙ()
   Dim ar, ak, i, j
    ar = Range("первая")
    ak = Range("вторая")
    For i = 1 To UBound(ar)
        For j = 1 To UBound(ak)
            If ar(i, 2) = ak(j, 1) Then
                If UCase(ar(i, 3)) = "ДА" Then '!!!!
                    If ar(i, 4) > 20 Then
                        ak(j, 2) = ar(i, 1) '!!!!
                        Exit For
                    End If
                End If
            End If
        Next j
    Next i
    Range("вторая") = ak '!!!!
End Sub
[/vba]

Но только такие вещи пробежкой массива по массиву не делаются - на более-менее больших диапазонах Excel сдохнет.
Вот примерно Ваш случай http://www.excelworld.ru/forum/10-38778-258819-16-1534706511
К сообщению приложен файл: 4799794_1.xlsm(17.5 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеВам нужно заполнить вторую таблицу датами из первой?
Тогда

[vba]
Код
Sub ЙЙЙЙ()
   Dim ar, ak, i, j
    ar = Range("первая")
    ak = Range("вторая")
    For i = 1 To UBound(ar)
        For j = 1 To UBound(ak)
            If ar(i, 2) = ak(j, 1) Then
                If UCase(ar(i, 3)) = "ДА" Then '!!!!
                    If ar(i, 4) > 20 Then
                        ak(j, 2) = ar(i, 1) '!!!!
                        Exit For
                    End If
                End If
            End If
        Next j
    Next i
    Range("вторая") = ak '!!!!
End Sub
[/vba]

Но только такие вещи пробежкой массива по массиву не делаются - на более-менее больших диапазонах Excel сдохнет.
Вот примерно Ваш случай http://www.excelworld.ru/forum/10-38778-258819-16-1534706511

Автор - _Boroda_
Дата добавления - 24.08.2018 в 14:06
AVI Дата: Суббота, 25.08.2018, 05:24 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 394
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
_Boroda_, Спасибо!

Просто с массивами мне хотя бы понятно как это работает более-менее, а по ссылке - дремучий лес.

У меня будут не такие большие объемы в ближайший год, в течение года, может быть и разберусь, когда с функционалом закончу и дойдут руки до оптимизации работы.
 
Ответить
Сообщение_Boroda_, Спасибо!

Просто с массивами мне хотя бы понятно как это работает более-менее, а по ссылке - дремучий лес.

У меня будут не такие большие объемы в ближайший год, в течение года, может быть и разберусь, когда с функционалом закончу и дойдут руки до оптимизации работы.

Автор - AVI
Дата добавления - 25.08.2018 в 05:24
AVI Дата: Вторник, 28.08.2018, 05:39 | Сообщение № 4
Группа: Проверенные
Ранг: Обитатель
Сообщений: 394
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
Тема та же как и вопрос, но пример другой.
И я все равно не понимаю как это работает. Чувствую себя тупым. Задача заполнить черную табличку данными из синей. И параллельно сделать так, что бы размер черной подстаривался под результат поиска.
Посмотрел справку Ubound и Lbound. Понял разницу, но почему если менять Ubound на Lbound, то ничего не происходит? Это же важно.
Пытаюсь сделать подумав - ничего не происходит. Пытаюсь сделать тупо по образу - тоже.
Пытаюсь докопаться до истины и меняю местами
[vba]
Код
    For i = 1 To UBound(ar)
        For j = 1 To UBound(ak)
[/vba]
Результат меняется, только почему он меняется?
К сообщению приложен файл: 3482321.xlsm(15.4 Kb)
 
Ответить
СообщениеТема та же как и вопрос, но пример другой.
И я все равно не понимаю как это работает. Чувствую себя тупым. Задача заполнить черную табличку данными из синей. И параллельно сделать так, что бы размер черной подстаривался под результат поиска.
Посмотрел справку Ubound и Lbound. Понял разницу, но почему если менять Ubound на Lbound, то ничего не происходит? Это же важно.
Пытаюсь сделать подумав - ничего не происходит. Пытаюсь сделать тупо по образу - тоже.
Пытаюсь докопаться до истины и меняю местами
[vba]
Код
    For i = 1 To UBound(ar)
        For j = 1 To UBound(ak)
[/vba]
Результат меняется, только почему он меняется?

Автор - AVI
Дата добавления - 28.08.2018 в 05:39
_Boroda_ Дата: Вторник, 28.08.2018, 09:12 | Сообщение № 5
Группа: Модераторы
Ранг: Местный житель
Сообщений: 12958
Репутация: 5330 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Задача заполнить черную табличку данными из синей. И параллельно сделать так, что бы размер черной подстаривался под результат поиска.

Конкретизируйте


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
Сообщение
Задача заполнить черную табличку данными из синей. И параллельно сделать так, что бы размер черной подстаривался под результат поиска.

Конкретизируйте

Автор - _Boroda_
Дата добавления - 28.08.2018 в 09:12
AVI Дата: Вторник, 28.08.2018, 09:56 | Сообщение № 6
Группа: Проверенные
Ранг: Обитатель
Сообщений: 394
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
_Boroda_, В примере
Мне дико не удобно, что я мусолю одну и ту же тему, но я не могу понять. Как не могу понять почему я не могу понять.
К сообщению приложен файл: 7137940.xlsm(15.7 Kb)
 
Ответить
Сообщение_Boroda_, В примере
Мне дико не удобно, что я мусолю одну и ту же тему, но я не могу понять. Как не могу понять почему я не могу понять.

Автор - AVI
Дата добавления - 28.08.2018 в 09:56
boa Дата: Вторник, 28.08.2018, 10:51 | Сообщение № 7
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 143
Репутация: 20 ±
Замечаний: 0% ±

2013, 365
AVI, так?
[vba]
Код
Sub bbb()
Dim ar, ak, i, j
Dim MyArr()
    ar = Range("Один")
        For i = 1 To UBound(ar)
            If ar(i, 1) > 10 Then
                j = j + 1
                ReDim Preserve MyArr(1 To 2, 1 To j)
                MyArr(1, j) = ar(i, 1)
                MyArr(2, j) = ar(i, 2)
            End If
         Next i
    Range("Два").Resize(UBound(MyArr, 2), 2) = Application.Transpose(MyArr)
End Sub
[/vba]
К сообщению приложен файл: 7137940_2.xlsm(17.6 Kb)


 
Ответить
СообщениеAVI, так?
[vba]
Код
Sub bbb()
Dim ar, ak, i, j
Dim MyArr()
    ar = Range("Один")
        For i = 1 To UBound(ar)
            If ar(i, 1) > 10 Then
                j = j + 1
                ReDim Preserve MyArr(1 To 2, 1 To j)
                MyArr(1, j) = ar(i, 1)
                MyArr(2, j) = ar(i, 2)
            End If
         Next i
    Range("Два").Resize(UBound(MyArr, 2), 2) = Application.Transpose(MyArr)
End Sub
[/vba]

Автор - boa
Дата добавления - 28.08.2018 в 10:51
_Boroda_ Дата: Вторник, 28.08.2018, 11:24 | Сообщение № 8
Группа: Модераторы
Ранг: Местный житель
Сообщений: 12958
Репутация: 5330 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Мне дико не удобно, что я мусолю одну и ту же тему

Вообще-то это два совершенно разных вопроса, почти никак друг с другом не связанных :D
С учетом того, что таблицу нужно перезаписывать и лишнее(если есть) стирать, получился такой код (для удобства там еще на листе выбор числа для сравнения и выбор > или <)
[vba]
Код
Sub tt()
    ar0 = Range("Один") 'массив первой таблицы
    n0_ = UBound(ar0) 'кол-во строк в нем
    ar1 = Range("Два").Resize(n0_) 'массив из кол-ва строк как в первой таблице и кол-ва столбцов как во второй
    us_ = Range("N12") 'условие
    z_ = Range("O12") 'значение для сравнения
    znak_ = 1 'для >
    If us_ = "<" Then znak_ = -1 'для <
    For i = 1 To n0_ 'цикл по строкам первой табл
        If ar0(i, 1) * znak_ > z_ * znak_ Then 'если условие выполнено, то
            n1_ = n1_ + 1 'счётчик увеличиваем на 1
            ar1(n1_, 1) = ar0(i, 2) 'заполняем n1-ую строку второго массива
            ar1(n1_, 2) = ar0(i, 3) 'заполняем n1-ую строку второго массива
        End If
    Next i
    Range("Два").ClearContents 'очищаем вторую таблицу
    With ActiveSheet.ListObjects("Два") 'работаем с ней как с объектом
        ad1_ = .Range(1).Address 'адрес первой ячейки таб 2
        .Resize Range(ad1_).Resize(n1_ + 1, 2) 'изменяем размер таб 2 на столько строк, сколько n1_ + шапка
        .Range(1).Offset(1).Resize(n1_, 2) = ar1 'вставляем туда массив ar1
    End With
End Sub
[/vba]
К сообщению приложен файл: 7137940_1.xlsm(19.7 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
Сообщение
Мне дико не удобно, что я мусолю одну и ту же тему

Вообще-то это два совершенно разных вопроса, почти никак друг с другом не связанных :D
С учетом того, что таблицу нужно перезаписывать и лишнее(если есть) стирать, получился такой код (для удобства там еще на листе выбор числа для сравнения и выбор > или <)
[vba]
Код
Sub tt()
    ar0 = Range("Один") 'массив первой таблицы
    n0_ = UBound(ar0) 'кол-во строк в нем
    ar1 = Range("Два").Resize(n0_) 'массив из кол-ва строк как в первой таблице и кол-ва столбцов как во второй
    us_ = Range("N12") 'условие
    z_ = Range("O12") 'значение для сравнения
    znak_ = 1 'для >
    If us_ = "<" Then znak_ = -1 'для <
    For i = 1 To n0_ 'цикл по строкам первой табл
        If ar0(i, 1) * znak_ > z_ * znak_ Then 'если условие выполнено, то
            n1_ = n1_ + 1 'счётчик увеличиваем на 1
            ar1(n1_, 1) = ar0(i, 2) 'заполняем n1-ую строку второго массива
            ar1(n1_, 2) = ar0(i, 3) 'заполняем n1-ую строку второго массива
        End If
    Next i
    Range("Два").ClearContents 'очищаем вторую таблицу
    With ActiveSheet.ListObjects("Два") 'работаем с ней как с объектом
        ad1_ = .Range(1).Address 'адрес первой ячейки таб 2
        .Resize Range(ad1_).Resize(n1_ + 1, 2) 'изменяем размер таб 2 на столько строк, сколько n1_ + шапка
        .Range(1).Offset(1).Resize(n1_, 2) = ar1 'вставляем туда массив ar1
    End With
End Sub
[/vba]

Автор - _Boroda_
Дата добавления - 28.08.2018 в 11:24
AVI Дата: Четверг, 30.08.2018, 16:50 | Сообщение № 9
Группа: Проверенные
Ранг: Обитатель
Сообщений: 394
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
_Boroda_, Спасибо, но слишком сложно. Можно сделать проще:во-первых, вторая таблица не умная, а в-вторых, само условие зашито в сам код, то есть
[vba]
Код
If ar(i, 1) > 10 Then
[/vba]
Я не понимаю как перенести результат поиска в во вторую таблицу.
К сообщению приложен файл: 9934432.xlsm(13.3 Kb)
 
Ответить
Сообщение_Boroda_, Спасибо, но слишком сложно. Можно сделать проще:во-первых, вторая таблица не умная, а в-вторых, само условие зашито в сам код, то есть
[vba]
Код
If ar(i, 1) > 10 Then
[/vba]
Я не понимаю как перенести результат поиска в во вторую таблицу.

Автор - AVI
Дата добавления - 30.08.2018 в 16:50
_Boroda_ Дата: Четверг, 30.08.2018, 18:27 | Сообщение № 10
Группа: Модераторы
Ранг: Местный житель
Сообщений: 12958
Репутация: 5330 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
слишком сложн
думал, Вам интересно будет посмотреть. Извините, погорячился, был неправ

[vba]
Код
Sub tt()
    ar0 = Range("Один") 'массив первой таблицы
    n0_ = UBound(ar0) 'кол-во строк в нем
    r0_ = 7 'первая строка во второй таблице (без шапки)
    r1_ = Cells(Rows.Count, 11).End(3).Row ' последняя строка второй табл
    If r1_ >= r0_ Then 'если табл 2 чем-то заполнена
        Cells(r0_, 11).Resize(r1_ - r0_ + 1, 2).Clear 'очищаем
    End If
    ar1 = Cells(r0_, 11).Resize(n0_, 2) 'пустой массив с кол-вом строк, как в первой таблице
    For i = 1 To n0_ 'цикл по строкам первой табл
        If ar0(i, 1) > 10 Then 'если условие выполнено, то
            n1_ = n1_ + 1 'счётчик увеличиваем на 1
            ar1(n1_, 1) = ar0(i, 2) 'заполняем ФИО второго массива
            ar1(n1_, 2) = ar0(i, 3) 'заполняем пол второго массива
        End If
    Next i
    Cells(r0_, 11).Resize(n1_, 2) = ar1 ' выводим во вторую таблицу столько строк массива аr1, сколько нашли в цикле проверки
End Sub
[/vba]
К сообщению приложен файл: 9934432_2.xlsm(15.7 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
Сообщение
слишком сложн
думал, Вам интересно будет посмотреть. Извините, погорячился, был неправ

[vba]
Код
Sub tt()
    ar0 = Range("Один") 'массив первой таблицы
    n0_ = UBound(ar0) 'кол-во строк в нем
    r0_ = 7 'первая строка во второй таблице (без шапки)
    r1_ = Cells(Rows.Count, 11).End(3).Row ' последняя строка второй табл
    If r1_ >= r0_ Then 'если табл 2 чем-то заполнена
        Cells(r0_, 11).Resize(r1_ - r0_ + 1, 2).Clear 'очищаем
    End If
    ar1 = Cells(r0_, 11).Resize(n0_, 2) 'пустой массив с кол-вом строк, как в первой таблице
    For i = 1 To n0_ 'цикл по строкам первой табл
        If ar0(i, 1) > 10 Then 'если условие выполнено, то
            n1_ = n1_ + 1 'счётчик увеличиваем на 1
            ar1(n1_, 1) = ar0(i, 2) 'заполняем ФИО второго массива
            ar1(n1_, 2) = ar0(i, 3) 'заполняем пол второго массива
        End If
    Next i
    Cells(r0_, 11).Resize(n1_, 2) = ar1 ' выводим во вторую таблицу столько строк массива аr1, сколько нашли в цикле проверки
End Sub
[/vba]

Автор - _Boroda_
Дата добавления - 30.08.2018 в 18:27
RAN Дата: Четверг, 30.08.2018, 20:36 | Сообщение № 11
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4831
Репутация: 968 ±
Замечаний: 0% ±

2010
Извините, погорячился, был неправ

Да, ты уж поаккуратней. Есть заказ - выполняй! И неча заказчика лишним грузить.


Быть или не быть, вот в чем загвоздка!
 
Ответить
Сообщение
Извините, погорячился, был неправ

Да, ты уж поаккуратней. Есть заказ - выполняй! И неча заказчика лишним грузить.

Автор - RAN
Дата добавления - 30.08.2018 в 20:36
AVI Дата: Пятница, 31.08.2018, 05:31 | Сообщение № 12
Группа: Проверенные
Ранг: Обитатель
Сообщений: 394
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
_Boroda_, Зря вы так. Сейчас, пока я щупаю азы для мне любой шаг в сторону - провал. Я мучал то, что Вы мне показывали до этого, а тут резко все по-другому. Поэтому и сложно. Для меня дико ценно то, что Вы пишите комментарии, за что я очень благодарен. Я понимаю как работает код в данном конкретном случае, но когда появляется необходимость, что-то существенно поменять, то сразу затык.
Но, с другой стороны " глаза боятся, а руки делают". Вижу новые команды - лезу за справкой и в этом плане ваша помощь не менее ценна, ибо без нее я даже и не знал, что именно мне надо искать
 
Ответить
Сообщение_Boroda_, Зря вы так. Сейчас, пока я щупаю азы для мне любой шаг в сторону - провал. Я мучал то, что Вы мне показывали до этого, а тут резко все по-другому. Поэтому и сложно. Для меня дико ценно то, что Вы пишите комментарии, за что я очень благодарен. Я понимаю как работает код в данном конкретном случае, но когда появляется необходимость, что-то существенно поменять, то сразу затык.
Но, с другой стороны " глаза боятся, а руки делают". Вижу новые команды - лезу за справкой и в этом плане ваша помощь не менее ценна, ибо без нее я даже и не знал, что именно мне надо искать

Автор - AVI
Дата добавления - 31.08.2018 в 05:31
_Boroda_ Дата: Пятница, 31.08.2018, 09:20 | Сообщение № 13
Группа: Модераторы
Ранг: Местный житель
Сообщений: 12958
Репутация: 5330 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Да ладно, Алексей, это я больше в шутку.

Вы молодец, что справку мучаете, но там не всегда нормально и понятно написано, поэтому не стесняйтесь здесь спрашивать. Тех, кто сам что-то пытается делать, здесь уважают и всегда помочь стараются.

И, кстати, задачи принципиально разные. В первой мы сравниваем значения из двух массивов (цикл в цикле или в словаре), а во второй проверка условия в одном массиве и вывод данных в другой. Поэтому конечно
резко все по-другому


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеДа ладно, Алексей, это я больше в шутку.

Вы молодец, что справку мучаете, но там не всегда нормально и понятно написано, поэтому не стесняйтесь здесь спрашивать. Тех, кто сам что-то пытается делать, здесь уважают и всегда помочь стараются.

И, кстати, задачи принципиально разные. В первой мы сравниваем значения из двух массивов (цикл в цикле или в словаре), а во второй проверка условия в одном массиве и вывод данных в другой. Поэтому конечно
резко все по-другому

Автор - _Boroda_
Дата добавления - 31.08.2018 в 09:20
AVI Дата: Суббота, 01.09.2018, 10:18 | Сообщение № 14
Группа: Проверенные
Ранг: Обитатель
Сообщений: 394
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
_Boroda_,
А как заставить его переносить данные на нужный лист, а то он работает только на открытом листе.

И еще у меня Option Explicit о чем я ранее не сообщил.


[vba]
Код
Dim ar0, n0_, r0_, r1_, ar1, i, n1, n1_ As Long

    ar0 = Range("РасшГруппНакл_tb") 'массив первой таблицы
    n0_ = UBound(ar0) 'кол-во строк в нем
    r0_ = 13 'первая строка во второй таблице (без шапки)
    r1_ = Cells(Rows.Count, 11).End(3).Row ' последняя строка второй табл
    If r1_ >= r0_ Then 'если табл 2 чем-то заполнена
        Worksheets("Отчет дневной стационар").Cells(r0_, 11).Resize(r1_ - r0_ + 1, 1).Clear 'очищаем
    End If
    ar1 = Worksheets("Отчет дневной стационар").Cells(r0_, 11).Resize(n0_, 2) 'пустой массив с кол-вом строк, как в первой таблице
    For i = 1 To n0_ 'цикл по строкам первой табл
        If ar0(i, 1) = "ДС" Then 'если условие выполнено, то
            n1_ = n1_ + 1 'счётчик увеличиваем на 1
            ar1(n1_, 1) = ar0(i, 3) 'заполняем ФИО второго массива
        End If
    Next i
    Worksheets("Отчет дневной стационар").Cells(r0_, 11).Resize(n1_, 2) = ar1 ' выводим во вторую таблицу столько строк массива аr1, сколько нашли в цикле проверки
[/vba]

Сам разобрался - вроде работает


Сообщение отредактировал AVI - Суббота, 01.09.2018, 10:31
 
Ответить
Сообщение_Boroda_,
А как заставить его переносить данные на нужный лист, а то он работает только на открытом листе.

И еще у меня Option Explicit о чем я ранее не сообщил.


[vba]
Код
Dim ar0, n0_, r0_, r1_, ar1, i, n1, n1_ As Long

    ar0 = Range("РасшГруппНакл_tb") 'массив первой таблицы
    n0_ = UBound(ar0) 'кол-во строк в нем
    r0_ = 13 'первая строка во второй таблице (без шапки)
    r1_ = Cells(Rows.Count, 11).End(3).Row ' последняя строка второй табл
    If r1_ >= r0_ Then 'если табл 2 чем-то заполнена
        Worksheets("Отчет дневной стационар").Cells(r0_, 11).Resize(r1_ - r0_ + 1, 1).Clear 'очищаем
    End If
    ar1 = Worksheets("Отчет дневной стационар").Cells(r0_, 11).Resize(n0_, 2) 'пустой массив с кол-вом строк, как в первой таблице
    For i = 1 To n0_ 'цикл по строкам первой табл
        If ar0(i, 1) = "ДС" Then 'если условие выполнено, то
            n1_ = n1_ + 1 'счётчик увеличиваем на 1
            ar1(n1_, 1) = ar0(i, 3) 'заполняем ФИО второго массива
        End If
    Next i
    Worksheets("Отчет дневной стационар").Cells(r0_, 11).Resize(n1_, 2) = ar1 ' выводим во вторую таблицу столько строк массива аr1, сколько нашли в цикле проверки
[/vba]

Сам разобрался - вроде работает

Автор - AVI
Дата добавления - 01.09.2018 в 10:18
boa Дата: Суббота, 01.09.2018, 10:31 | Сообщение № 15
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 143
Репутация: 20 ±
Замечаний: 0% ±

2013, 365
AVI,
перед обращением к ячейке "Cells(..." добавьте указание на конкретный лист [vba]
Код
sheets("нужный лист").Cells(...
[/vba]


 
Ответить
СообщениеAVI,
перед обращением к ячейке "Cells(..." добавьте указание на конкретный лист [vba]
Код
sheets("нужный лист").Cells(...
[/vba]

Автор - boa
Дата добавления - 01.09.2018 в 10:31
_Boroda_ Дата: Суббота, 01.09.2018, 15:02 | Сообщение № 16
Группа: Модераторы
Ранг: Местный житель
Сообщений: 12958
Репутация: 5330 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
AVI,
1.
Dim ar0, n0_, r0_, r1_, ar1, i, n1, n1_ As Long
сделает Long только переменную n1_/ Все остальные будут Variant. В VBA нужно писать обзывалку с "as" на каждую переменную отдельно
2. Почитайте про конструкцию With - End With. С ее помощью можно написать так (и компактнее, и легче читается, и быстрее работает)
[vba]
Код

With Worksheets("Отчет дневной стационар")
    ar0 = Range("РасшГруппНакл_tb") 'массив первой таблицы
    n0_ = UBound(ar0) 'кол-во строк в нем
    r0_ = 13 'первая строка во второй таблице (без шапки)
    r1_ = .Cells(Rows.Count, 11).End(3).Row ' последняя строка второй табл !!!!! Здесь забыли указать лист !!!!!
    If r1_ >= r0_ Then 'если табл 2 чем-то заполнена
        .Cells(r0_, 11).Resize(r1_ - r0_ + 1, 1).Clear 'очищаем
    End If
    ar1 = .Cells(r0_, 11).Resize(n0_, 2) 'пустой массив с кол-вом строк, как в первой таблице
    For i = 1 To n0_ 'цикл по строкам первой табл
        If ar0(i, 1) = "ДС" Then 'если условие выполнено, то
            n1_ = n1_ + 1 'счётчик увеличиваем на 1
            ar1(n1_, 1) = ar0(i, 3) 'заполняем ФИО второго массива
        End If
    Next i
    .Cells(r0_, 11).Resize(n1_, 2) = ar1
End With
[/vba]


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеAVI,
1.
Dim ar0, n0_, r0_, r1_, ar1, i, n1, n1_ As Long
сделает Long только переменную n1_/ Все остальные будут Variant. В VBA нужно писать обзывалку с "as" на каждую переменную отдельно
2. Почитайте про конструкцию With - End With. С ее помощью можно написать так (и компактнее, и легче читается, и быстрее работает)
[vba]
Код

With Worksheets("Отчет дневной стационар")
    ar0 = Range("РасшГруппНакл_tb") 'массив первой таблицы
    n0_ = UBound(ar0) 'кол-во строк в нем
    r0_ = 13 'первая строка во второй таблице (без шапки)
    r1_ = .Cells(Rows.Count, 11).End(3).Row ' последняя строка второй табл !!!!! Здесь забыли указать лист !!!!!
    If r1_ >= r0_ Then 'если табл 2 чем-то заполнена
        .Cells(r0_, 11).Resize(r1_ - r0_ + 1, 1).Clear 'очищаем
    End If
    ar1 = .Cells(r0_, 11).Resize(n0_, 2) 'пустой массив с кол-вом строк, как в первой таблице
    For i = 1 To n0_ 'цикл по строкам первой табл
        If ar0(i, 1) = "ДС" Then 'если условие выполнено, то
            n1_ = n1_ + 1 'счётчик увеличиваем на 1
            ar1(n1_, 1) = ar0(i, 3) 'заполняем ФИО второго массива
        End If
    Next i
    .Cells(r0_, 11).Resize(n1_, 2) = ar1
End With
[/vba]

Автор - _Boroda_
Дата добавления - 01.09.2018 в 15:02
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Отбор и перенос данных в умных таблицах (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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