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

Вход

Регистрация

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

 

= Мир MS Excel/Расширить диапазон переноса данных - Мир MS Excel

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

Excel 2016
Добрый день!
Подскажите, пожалуйста, как сделать так, что бы код переносил данные не только из третьtго столбца таблицы "Расчет", но и десяти столбцов после него?
К сообщению приложен файл: _Microsoft_Exce.xlsm(47.4 Kb)
 
Ответить
СообщениеДобрый день!
Подскажите, пожалуйста, как сделать так, что бы код переносил данные не только из третьtго столбца таблицы "Расчет", но и десяти столбцов после него?

Автор - AVI
Дата добавления - 15.01.2019 в 06:01
Pelena Дата: Вторник, 15.01.2019, 09:08 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 13660
Репутация: 3004 ±
Замечаний: ±

Excel 2010, 2016 & Mac Excel
Здравствуйте.
Вариант
[vba]
Код
Sub qqq_1()
    Dim r0_, r1_, ar1
    Dim oTbl As ListObject
    Set oTbl = Sheets("Лист2").ListObjects("Расчет")
    r0_ = 6
    With Worksheets("Лист1")
        r1_ = .Cells(Rows.Count, 4).End(3).Row
        If r1_ >= r0_ Then
            .Cells(r0_, 4).Resize(r1_ - r0_ + 1, 10).ClearContents
        End If
        With oTbl.Sort
            .SortFields.Clear
            .SortFields.Add oTbl.ListColumns("Направление").Range
            .Apply
        End With
        oTbl.Range.AutoFilter 2, .Range("D2")
        ar1 = oTbl.DataBodyRange.Columns(3).Resize(, 10).SpecialCells(xlVisible)
        .Cells(r0_, 4).Resize(, 10) = oTbl.HeaderRowRange.Columns(3).Resize(, 10).Value
        .Cells(r0_ + 1, 4).Resize(UBound(ar1), 10) = ar1
        oTbl.DataBodyRange.AutoFilter 2
    End With
End Sub
[/vba]
Если таблица не всегда отсортирована по столбцу Направление, то надо ещё добавить в макрос сортировку.Добавила
К сообщению приложен файл: 1984665.xlsm(49.3 Kb)


"Черт возьми, Холмс! Но как??!!"
ЯД 41001765434816


Сообщение отредактировал Pelena - Вторник, 15.01.2019, 09:50
 
Ответить
СообщениеЗдравствуйте.
Вариант
[vba]
Код
Sub qqq_1()
    Dim r0_, r1_, ar1
    Dim oTbl As ListObject
    Set oTbl = Sheets("Лист2").ListObjects("Расчет")
    r0_ = 6
    With Worksheets("Лист1")
        r1_ = .Cells(Rows.Count, 4).End(3).Row
        If r1_ >= r0_ Then
            .Cells(r0_, 4).Resize(r1_ - r0_ + 1, 10).ClearContents
        End If
        With oTbl.Sort
            .SortFields.Clear
            .SortFields.Add oTbl.ListColumns("Направление").Range
            .Apply
        End With
        oTbl.Range.AutoFilter 2, .Range("D2")
        ar1 = oTbl.DataBodyRange.Columns(3).Resize(, 10).SpecialCells(xlVisible)
        .Cells(r0_, 4).Resize(, 10) = oTbl.HeaderRowRange.Columns(3).Resize(, 10).Value
        .Cells(r0_ + 1, 4).Resize(UBound(ar1), 10) = ar1
        oTbl.DataBodyRange.AutoFilter 2
    End With
End Sub
[/vba]
Если таблица не всегда отсортирована по столбцу Направление, то надо ещё добавить в макрос сортировку.Добавила

Автор - Pelena
Дата добавления - 15.01.2019 в 09:08
vikttur Дата: Вторник, 15.01.2019, 09:12 | Сообщение № 3
Группа: Друзья
Ранг: Старожил
Сообщений: 2895
Репутация: 519 ±
Замечаний: 0% ±

Сначала дополнил код... Потом решил переделать:
[vba]
Код
Sub Filtr_()
Dim ar0(), ar1()
Dim sStr As String
Dim i As Long, k As Long, j As Long
Const lRw As Byte = 6
    With Worksheets("Лист2")
        i = .UsedRange.Rows.Count: If i < 2 Then Exit Sub
        ar0 = .Range("C1:N" & i).Value
    End With
    
    ReDim ar1(1 To i, 1 To 10)
        
    With Worksheets("Лист1")
        sStr = .Range("D2").Value
        .Columns(4).Resize(, 10).ClearContents
        .Range("D2").Value = sStr

        For i = 2 To UBound(ar0)
            If ar0(i, 1) = sStr Then
                k = k + 1
                
                For j = 1 To 10
                    ar1(k, j) = ar0(i, j + 1)
                Next j
            End If
        Next i
        
        .Cells(lRw, 4).Resize(k, 10).Value = ar1
    End With
End Sub
[/vba]


Сообщение отредактировал vikttur - Вторник, 15.01.2019, 10:26
 
Ответить
СообщениеСначала дополнил код... Потом решил переделать:
[vba]
Код
Sub Filtr_()
Dim ar0(), ar1()
Dim sStr As String
Dim i As Long, k As Long, j As Long
Const lRw As Byte = 6
    With Worksheets("Лист2")
        i = .UsedRange.Rows.Count: If i < 2 Then Exit Sub
        ar0 = .Range("C1:N" & i).Value
    End With
    
    ReDim ar1(1 To i, 1 To 10)
        
    With Worksheets("Лист1")
        sStr = .Range("D2").Value
        .Columns(4).Resize(, 10).ClearContents
        .Range("D2").Value = sStr

        For i = 2 To UBound(ar0)
            If ar0(i, 1) = sStr Then
                k = k + 1
                
                For j = 1 To 10
                    ar1(k, j) = ar0(i, j + 1)
                Next j
            End If
        Next i
        
        .Cells(lRw, 4).Resize(k, 10).Value = ar1
    End With
End Sub
[/vba]

Автор - vikttur
Дата добавления - 15.01.2019 в 09:12
_Boroda_ Дата: Вторник, 15.01.2019, 09:48 | Сообщение № 4
Группа: Модераторы
Ранг: Местный житель
Сообщений: 14125
Репутация: 5696 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Еще вариант

[vba]
Код
Sub tt()
    x_ = Range("D2")
    With Worksheets("Лист2")
        r00_ = .Columns("C:C").Find(x_).Row
        n1_ = WorksheetFunction.CountIf(.Columns("C:C"), x_)
        ar0 = Range("Расчет")
        n0_ = UBound(ar0)
        r0_ = 6
        r1_ = .Cells(Rows.Count, 4).End(3).Row
        If r1_ >= r0_ Then
            Cells(r0_, 4).Resize(r1_ - r0_ + 1, 10).Clear
        End If
        .Cells(r00_, 4).Resize(n1_, 10).Copy Cells(r0_, 4).Resize(n1_, 10)
    End With
End Sub
[/vba]
Если таблица не всегда отсортирована по столбцу Направление, то надо ещё добавить в макрос сортировку
или фильтрацию
К сообщению приложен файл: 4931401.xlsm(49.8 Kb)


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

[vba]
Код
Sub tt()
    x_ = Range("D2")
    With Worksheets("Лист2")
        r00_ = .Columns("C:C").Find(x_).Row
        n1_ = WorksheetFunction.CountIf(.Columns("C:C"), x_)
        ar0 = Range("Расчет")
        n0_ = UBound(ar0)
        r0_ = 6
        r1_ = .Cells(Rows.Count, 4).End(3).Row
        If r1_ >= r0_ Then
            Cells(r0_, 4).Resize(r1_ - r0_ + 1, 10).Clear
        End If
        .Cells(r00_, 4).Resize(n1_, 10).Copy Cells(r0_, 4).Resize(n1_, 10)
    End With
End Sub
[/vba]
Если таблица не всегда отсортирована по столбцу Направление, то надо ещё добавить в макрос сортировку
или фильтрацию

Автор - _Boroda_
Дата добавления - 15.01.2019 в 09:48
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Расширить диапазон переноса данных (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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