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

Вход

Регистрация

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

 

= Мир MS Excel/копирование значений из таблицы на лист согл. классу(критери - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » копирование значений из таблицы на лист согл. классу(критери (Макросы/Sub)
копирование значений из таблицы на лист согл. классу(критери
lebensvoll Дата: Понедельник, 30.10.2017, 15:03 | Сообщение № 1
Группа: Проверенные
Ранг: Старожил
Сообщений: 1002
Репутация: 30 ±
Замечаний: 0% ±

Excel 2010
Добрый день много уважаемые форумчане!!!
Прошу Вас помочь (и разобраться для понимания) и в тоже самое время скорректировать код. Заранее СПАСИБО за отзывчивость и помощь!!!
Имеются данные на листе "БЕТОН" хотелось бы чтоб при выполнении макроса "Класс/Марка" с листа "Бетон" копировались значения по листам (7,5; 10; 12,5; 15; 20; 22,5; 25; 30; 35; 40)
К примеру если это бетон класс 7,5 то все эти значения копировались на лист 7,5 и также по аналогии по другим классам (см.скрин)

Сам код вот такой вот (но возникают проблемы при выполнении данного макроса)
[vba]
Код
Option Explicit
Sub Macro()
        Application.ScreenUpdating = False
    Call ttt1(Sheets("7,5"))
    Call ttt1(Sheets("10"))
    Call ttt1(Sheets("12,5"))
    Call ttt1(Sheets("15"))
    Call ttt1(Sheets("20"))
    Call ttt1(Sheets("22,5"))
    Call ttt1(Sheets("25"))
    Call ttt1(Sheets("30"))
    Call ttt1(Sheets("35"))
    Call ttt1(Sheets("40"))
    Application.ScreenUpdating = True
    MsgBox "готово!", vbInformation
End Sub

Private Sub ttt1(shTrt As Excel.Worksheet)
    Dim i As Long
    For i = 1 To Sheets.Count - 3
        Call ttt2(Sheets(i), shTrt)
    Next
End Sub

Private Sub ttt2(shSrc As Excel.Worksheet, shTrt As Excel.Worksheet)
    Dim arrE()
    Dim strType As String
    Dim lngStart As Long, lngEnd As Long, lngRowsCount As Long
    Dim lngLastRow As Long
    Dim i As Long
    strType = shTrt.Name
    arrE = shSrc.Range("C1:C" & shSrc.UsedRange.Row + shSrc.UsedRange.Rows.Count - 1).Value
    For i = 1 To UBound(arrE)
        If CStr(arrE(i, 1)) = strType Then
            lngStart = i
            Exit For
        End If
    Next
    If lngStart = 0 Then
        Exit Sub
    End If
    i = lngStart + 1
    Do
        If CStr(arrE(i, 1)) <> strType Or i > UBound(arrE) Then
            lngEnd = i - 1
            Exit Do
        Else
            i = i + 1
        End If
    Loop
    lngRowsCount = lngEnd - lngStart + 1
    lngLastRow = shTrt.UsedRange.Row + shTrt.UsedRange.Rows.Count
    shTrt.Cells(lngLastRow, "A").Resize(lngRowsCount, 20).Value = _
        shSrc.Cells(lngStart, "D").Resize(lngRowsCount, 20).Value
    End Sub
[/vba]
К сообщению приложен файл: Avg__.xlsm (45.2 Kb)

Кто бы ты ни был, мир в твоих руках

Сообщение отредактировал lebensvoll - Понедельник, 30.10.2017, 15:04
 
Ответить
СообщениеДобрый день много уважаемые форумчане!!!
Прошу Вас помочь (и разобраться для понимания) и в тоже самое время скорректировать код. Заранее СПАСИБО за отзывчивость и помощь!!!
Имеются данные на листе "БЕТОН" хотелось бы чтоб при выполнении макроса "Класс/Марка" с листа "Бетон" копировались значения по листам (7,5; 10; 12,5; 15; 20; 22,5; 25; 30; 35; 40)
К примеру если это бетон класс 7,5 то все эти значения копировались на лист 7,5 и также по аналогии по другим классам (см.скрин)

Сам код вот такой вот (но возникают проблемы при выполнении данного макроса)
[vba]
Код
Option Explicit
Sub Macro()
        Application.ScreenUpdating = False
    Call ttt1(Sheets("7,5"))
    Call ttt1(Sheets("10"))
    Call ttt1(Sheets("12,5"))
    Call ttt1(Sheets("15"))
    Call ttt1(Sheets("20"))
    Call ttt1(Sheets("22,5"))
    Call ttt1(Sheets("25"))
    Call ttt1(Sheets("30"))
    Call ttt1(Sheets("35"))
    Call ttt1(Sheets("40"))
    Application.ScreenUpdating = True
    MsgBox "готово!", vbInformation
End Sub

Private Sub ttt1(shTrt As Excel.Worksheet)
    Dim i As Long
    For i = 1 To Sheets.Count - 3
        Call ttt2(Sheets(i), shTrt)
    Next
End Sub

Private Sub ttt2(shSrc As Excel.Worksheet, shTrt As Excel.Worksheet)
    Dim arrE()
    Dim strType As String
    Dim lngStart As Long, lngEnd As Long, lngRowsCount As Long
    Dim lngLastRow As Long
    Dim i As Long
    strType = shTrt.Name
    arrE = shSrc.Range("C1:C" & shSrc.UsedRange.Row + shSrc.UsedRange.Rows.Count - 1).Value
    For i = 1 To UBound(arrE)
        If CStr(arrE(i, 1)) = strType Then
            lngStart = i
            Exit For
        End If
    Next
    If lngStart = 0 Then
        Exit Sub
    End If
    i = lngStart + 1
    Do
        If CStr(arrE(i, 1)) <> strType Or i > UBound(arrE) Then
            lngEnd = i - 1
            Exit Do
        Else
            i = i + 1
        End If
    Loop
    lngRowsCount = lngEnd - lngStart + 1
    lngLastRow = shTrt.UsedRange.Row + shTrt.UsedRange.Rows.Count
    shTrt.Cells(lngLastRow, "A").Resize(lngRowsCount, 20).Value = _
        shSrc.Cells(lngStart, "D").Resize(lngRowsCount, 20).Value
    End Sub
[/vba]
Автор - lebensvoll
Дата добавления - 30.10.2017 в 15:03
nilem Дата: Понедельник, 30.10.2017, 15:15 | Сообщение № 2
Группа: Авторы
Ранг: Старожил
Сообщений: 1613
Репутация: 563 ±
Замечаний: 0% ±

Excel 2013, 2016
lebensvoll, привет
вот здесь похожая задачка

Яндекс.Деньги 4100159601573
 
Ответить
Сообщениеlebensvoll, привет
вот здесь похожая задачка
Автор - nilem
Дата добавления - 30.10.2017 в 15:15
lebensvoll Дата: Понедельник, 30.10.2017, 15:44 | Сообщение № 3
Группа: Проверенные
Ранг: Старожил
Сообщений: 1002
Репутация: 30 ±
Замечаний: 0% ±

Excel 2010
nilem, спасибо огромное, я постараюсь разобраться с примером по ссылке.
Но боюсь что я не справлюсь (((( теряюсь в понимание этих кодов.

Кто бы ты ни был, мир в твоих руках
 
Ответить
Сообщениеnilem, спасибо огромное, я постараюсь разобраться с примером по ссылке.
Но боюсь что я не справлюсь (((( теряюсь в понимание этих кодов.
Автор - lebensvoll
Дата добавления - 30.10.2017 в 15:44
nilem Дата: Понедельник, 30.10.2017, 16:12 | Сообщение № 4
Группа: Авторы
Ранг: Старожил
Сообщений: 1613
Репутация: 563 ±
Замечаний: 0% ±

Excel 2013, 2016
Ну не может быть, чтоб не справились )
В крайнем случае - пишите, придумаем что-нибудь.

Яндекс.Деньги 4100159601573
 
Ответить
СообщениеНу не может быть, чтоб не справились )
В крайнем случае - пишите, придумаем что-нибудь.
Автор - nilem
Дата добавления - 30.10.2017 в 16:12
Kuzmich Дата: Понедельник, 30.10.2017, 16:22 | Сообщение № 5
Группа: Проверенные
Ранг: Ветеран
Сообщений: 711
Репутация: 156 ±
Замечаний: 0% ±

Excel 2003
[vba]
Код

'запускать при активном листе Бетон
Sub RaznestiDannye()
Dim i As Long
Dim iLastRow As Long
Dim iLR_Unic As Long
Dim Criterij As String
Dim Autofilter As Autofilter
Application.ScreenUpdating = False
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   With Range("C1:C" & iLastRow)
     .Replace what:=".", replacement:=","
   End With
Range("C1:C" & iLastRow).TextToColumns
Range("K1:K" & iLastRow).ClearContents
Range("C1:C" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("K1"), Unique:=True
  iLR_Unic = Cells(Rows.Count, "K").End(xlUp).Row
    For i = 2 To iLR_Unic          'цикл по класс/маркам
        Criterij = Cells(i, "K")
    'ставим автофильтр по столбцу C
          Range("A1").CurrentRegion.Autofilter 3, Criterij
    'копируем видимые строки
      With Worksheets(Criterij)
        .Cells.Clear
        ActiveSheet.Autofilter.Range.SpecialCells(xlCellTypeVisible).Copy .Range("A1")
        ActiveSheet.Autofilter.Range.Autofilter
      End With
    Next
Application.ScreenUpdating = True
End Sub
[/vba]
 
Ответить
Сообщение[vba]
Код

'запускать при активном листе Бетон
Sub RaznestiDannye()
Dim i As Long
Dim iLastRow As Long
Dim iLR_Unic As Long
Dim Criterij As String
Dim Autofilter As Autofilter
Application.ScreenUpdating = False
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   With Range("C1:C" & iLastRow)
     .Replace what:=".", replacement:=","
   End With
Range("C1:C" & iLastRow).TextToColumns
Range("K1:K" & iLastRow).ClearContents
Range("C1:C" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("K1"), Unique:=True
  iLR_Unic = Cells(Rows.Count, "K").End(xlUp).Row
    For i = 2 To iLR_Unic          'цикл по класс/маркам
        Criterij = Cells(i, "K")
    'ставим автофильтр по столбцу C
          Range("A1").CurrentRegion.Autofilter 3, Criterij
    'копируем видимые строки
      With Worksheets(Criterij)
        .Cells.Clear
        ActiveSheet.Autofilter.Range.SpecialCells(xlCellTypeVisible).Copy .Range("A1")
        ActiveSheet.Autofilter.Range.Autofilter
      End With
    Next
Application.ScreenUpdating = True
End Sub
[/vba]
Автор - Kuzmich
Дата добавления - 30.10.2017 в 16:22
_Boroda_ Дата: Понедельник, 30.10.2017, 16:39 | Сообщение № 6
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16675
Репутация: 6481 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
У меня так получилось
[vba]
Код
Sub ttr()
    Dim sh As Worksheet
    Application.ScreenUpdating = 0
    Application.Calculation = xlCalculationManual
    With ActiveSheet
        r_ = .Range("A" & .Rows.Count).End(xlUp).Row
        c_ = .Cells(1, .Columns.Count).End(xlToLeft).Column
        If .AutoFilterMode Then'если есть автофильтр
            .Range("A1").AutoFilter'снимаем его - мы ж не знаем на какой диапазон он поставлен
        End If
        .Range("A1").Resize(r_, c_).AutoFilter'ставим автофильтр
        For Each sh In ThisWorkbook.Worksheets'цикл по листам
            shn_ = sh.Name
            If shn_ <> .Name Then
                .Range("$A$1").AutoFilter Field:=3, Criteria1:=shn_
                .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy sh.Range("A1")
                With sh'ставим автофильтры на всех листах. Если не нужно - сотрите 6 строк With - End With
                    If .AutoFilterMode Then
                        .Range("A1").AutoFilter
                    End If
                    .Range("A1").Resize(r_, c_).AutoFilter
                End With
            End If
        Next sh
        .ShowAllData
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = 1
    MsgBox "Всё"
End Sub
[/vba]
К сообщению приложен файл: Avg_1.xlsm (69.2 Kb)

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеУ меня так получилось
[vba]
Код
Sub ttr()
    Dim sh As Worksheet
    Application.ScreenUpdating = 0
    Application.Calculation = xlCalculationManual
    With ActiveSheet
        r_ = .Range("A" & .Rows.Count).End(xlUp).Row
        c_ = .Cells(1, .Columns.Count).End(xlToLeft).Column
        If .AutoFilterMode Then'если есть автофильтр
            .Range("A1").AutoFilter'снимаем его - мы ж не знаем на какой диапазон он поставлен
        End If
        .Range("A1").Resize(r_, c_).AutoFilter'ставим автофильтр
        For Each sh In ThisWorkbook.Worksheets'цикл по листам
            shn_ = sh.Name
            If shn_ <> .Name Then
                .Range("$A$1").AutoFilter Field:=3, Criteria1:=shn_
                .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy sh.Range("A1")
                With sh'ставим автофильтры на всех листах. Если не нужно - сотрите 6 строк With - End With
                    If .AutoFilterMode Then
                        .Range("A1").AutoFilter
                    End If
                    .Range("A1").Resize(r_, c_).AutoFilter
                End With
            End If
        Next sh
        .ShowAllData
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = 1
    MsgBox "Всё"
End Sub
[/vba]
Автор - _Boroda_
Дата добавления - 30.10.2017 в 16:39
lebensvoll Дата: Понедельник, 30.10.2017, 16:59 | Сообщение № 7
Группа: Проверенные
Ранг: Старожил
Сообщений: 1002
Репутация: 30 ±
Замечаний: 0% ±

Excel 2010
Спасибо ВАМ всем огромнейшее...
Но я бы точно не разобрался да еще и поправить код ((((

Кто бы ты ни был, мир в твоих руках
 
Ответить
СообщениеСпасибо ВАМ всем огромнейшее...
Но я бы точно не разобрался да еще и поправить код ((((
Автор - lebensvoll
Дата добавления - 30.10.2017 в 16:59
Мир MS Excel » Вопросы и решения » Вопросы по VBA » копирование значений из таблицы на лист согл. классу(критери (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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