Страницы: 1
RSS
Группировать данные в отделенные таблицы по признаку (шифру "Литеры")
 
Добрый вечер дорогие форумчане, помогите решить задачу макросами. Есть таблица с 2-мя листами: Лист1, Лист2. На листе 2 заполняется список в произвольном порядке и проставляется литера ("Д", "М", "Н", "Р" и т.д) в столбце А. Задача: перенести строки на лист 1 и распределить по условиям. Поможете?
С уважением, Виктор
 
bybys, количество литер каждой литеры неизвестно?
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, Неизвестно
 
bybys, переформулируйтк название. Предложите новое - модераторы поменяют.
 
Юрий М, подскажите как это сделать?
 
Что ЭТО?
 
Цитата
Юрий М написал:
переформулируйтк название. Предложите новое - модераторы поменяют.
Вот это.  
 
Не понимаю, что здесь сложного  В следующем своём сообщении напишите: Предлагаю новое название ...(тут новое название темы).
 
Предлагаю новое название: Распределение строк из выборки по условиям  
 
Может ещё кто-нибудь придумает, если поняли задачу? Предлагаемое автором ничуть не лучше имеющегося.
 
bybys, Тема: Группировать данные в отделенные таблицы по признаку (шифру "Литеры")
скорее всего не то что  Вам необходимо... но может пригодиться, правда не обратил внимание что литеры могут быть
Цитата
bybys написал:
и т.д)
сделал для 4-х литер. Думаю, что можно все компактнее сделать, но пока учусь, может кто лучше вариант предложит.
Код
Sub ddd()
Dim i As Integer
Dim Rcell As Range
Dim myRange As Range
Dim DRange As Range
Dim MRange As Range
Dim NRange As Range
Dim RRange As Range
Application.ScreenUpdating = False
Range("A1:E10000").Clear
    ilastrow = Worksheets("Лист2").Cells(Rows.Count, 1).End(xlUp).Row
    Set myRange = Worksheets("Лист2").Range("A2:A" & ilastrow)
    For Each Rcell In myRange
    If Rcell.Value = "Д" Then
    If DRange Is Nothing Then
        Set DRange = Rcell.Offset(0, 1).Resize(, 4)
    Else
        Set DRange = Union(Rcell.Offset(0, 1).Resize(, 4), DRange)
        End If
    End If
        If Rcell.Value = "М" Then
    If MRange Is Nothing Then
        Set MRange = Rcell.Offset(0, 1).Resize(, 4)
    Else
        Set MRange = Union(Rcell.Offset(0, 1).Resize(, 4), MRange)
        End If
    End If
        If Rcell.Value = "Н" Then
    If NRange Is Nothing Then
        Set NRange = Rcell.Offset(0, 1).Resize(, 4)
    Else
        Set NRange = Union(Rcell.Offset(0, 1).Resize(, 4), NRange)
        End If
    End If
        If Rcell.Value = "Р" Then
    If RRange Is Nothing Then
        Set RRange = Rcell.Offset(0, 1).Resize(, 4)
    Else
        Set RRange = Union(Rcell.Offset(0, 1).Resize(, 4), RRange)
        End If
    End If
    Next Rcell
    
    ilastrow2 = Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row
    Worksheets("Лист1").Cells(ilastrow2 + 1, 2) = "Дымоход"
    Worksheets("Лист2").Range("C1:E1").Copy
    ActiveSheet.Paste Destination:=Worksheets("Лист1").Cells(ilastrow2 + 1, 3)
    If Not DRange Is Nothing Then DRange.Copy
    Cells(Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row + 1, 2).Select
    ActiveSheet.Paste
 
    ilastrow2 = Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row
    Worksheets("Лист1").Cells(ilastrow2 + 1, 2) = "Материал"
    Worksheets("Лист2").Range("C1:E1").Copy
    ActiveSheet.Paste Destination:=Worksheets("Лист1").Cells(ilastrow2 + 1, 3)
    If Not MRange Is Nothing Then MRange.Copy
    Cells(Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row + 1, 2).Select
    ActiveSheet.Paste
    
    ilastrow2 = Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row
    Worksheets("Лист1").Cells(ilastrow2 + 1, 2) = "НРасходы"
    Worksheets("Лист2").Range("C1:E1").Copy
    ActiveSheet.Paste Destination:=Worksheets("Лист1").Cells(ilastrow2 + 1, 3)
    If Not NRange Is Nothing Then NRange.Copy
    Cells(Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row + 1, 2).Select
    ActiveSheet.Paste
    
    ilastrow2 = Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row
    Worksheets("Лист1").Cells(ilastrow2 + 1, 2) = "Работы"
    Worksheets("Лист2").Range("C1:E1").Copy
    ActiveSheet.Paste Destination:=Worksheets("Лист1").Cells(ilastrow2 + 1, 3)
    If Not RRange Is Nothing Then RRange.Copy
    Cells(Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row + 1, 2).Select
    ActiveSheet.Paste
Application.ScreenUpdating = True
End Sub
Изменено: Mershik - 27.03.2020 23:57:51
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, Огонь! Только, если я кол-во не указываю на Листе2, строки не должны переноситься в Лист1) :oops:  Огромное спасибо
 
bybys,
Код
Sub ddd()
Dim i As Integer
Dim Rcell As Range
Dim myRange As Range
Dim DRange As Range
Dim MRange As Range
Dim NRange As Range
Dim RRange As Range
Application.ScreenUpdating = False
Range("A1:E10000").Clear
    ilastrow = Worksheets("Лист2").Cells(Rows.Count, 1).End(xlUp).Row
    Set myRange = Worksheets("Лист2").Range("A2:A" & ilastrow)
    For Each Rcell In myRange
    If Rcell.Value = "Д" And Rcell.Offset(0, 2).Value > 0 Then
    If DRange Is Nothing Then
        Set DRange = Rcell.Offset(0, 1).Resize(, 4)
    Else
        Set DRange = Union(Rcell.Offset(0, 1).Resize(, 4), DRange)
        End If
    End If
        If Rcell.Value = "М" And Rcell.Offset(0, 2).Value > 0 Then
    If MRange Is Nothing Then
        Set MRange = Rcell.Offset(0, 1).Resize(, 4)
    Else
        Set MRange = Union(Rcell.Offset(0, 1).Resize(, 4), MRange)
        End If
    End If
        If Rcell.Value = "Н" And Rcell.Offset(0, 2).Value > 0 Then
    If NRange Is Nothing Then
        Set NRange = Rcell.Offset(0, 1).Resize(, 4)
    Else
        Set NRange = Union(Rcell.Offset(0, 1).Resize(, 4), NRange)
        End If
    End If
        If Rcell.Value = "Р" And Rcell.Offset(0, 2).Value > 0 Then
    If RRange Is Nothing Then
        Set RRange = Rcell.Offset(0, 1).Resize(, 4)
    Else
        Set RRange = Union(Rcell.Offset(0, 1).Resize(, 4), RRange)
        End If
    End If
    Next Rcell
    
    ilastrow2 = Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row
    Worksheets("Лист1").Cells(ilastrow2 + 1, 2) = "Дымоход"
    Worksheets("Лист2").Range("C1:E1").Copy
    ActiveSheet.Paste Destination:=Worksheets("Лист1").Cells(ilastrow2 + 1, 3)
    If Not DRange Is Nothing Then DRange.Copy
    Cells(Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row + 1, 2).Select
    ActiveSheet.Paste
 
    ilastrow2 = Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row
    Worksheets("Лист1").Cells(ilastrow2 + 1, 2) = "Материал"
    Worksheets("Лист2").Range("C1:E1").Copy
    ActiveSheet.Paste Destination:=Worksheets("Лист1").Cells(ilastrow2 + 1, 3)
    If Not MRange Is Nothing Then MRange.Copy
    Cells(Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row + 1, 2).Select
    ActiveSheet.Paste
    
    ilastrow2 = Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row
    Worksheets("Лист1").Cells(ilastrow2 + 1, 2) = "НРасходы"
    Worksheets("Лист2").Range("C1:E1").Copy
    ActiveSheet.Paste Destination:=Worksheets("Лист1").Cells(ilastrow2 + 1, 3)
    If Not NRange Is Nothing Then NRange.Copy
    Cells(Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row + 1, 2).Select
    ActiveSheet.Paste
    
    ilastrow2 = Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row
    Worksheets("Лист1").Cells(ilastrow2 + 1, 2) = "Работы"
    Worksheets("Лист2").Range("C1:E1").Copy
    ActiveSheet.Paste Destination:=Worksheets("Лист1").Cells(ilastrow2 + 1, 3)
    If Not RRange Is Nothing Then RRange.Copy
    Cells(Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row + 1, 2).Select
    ActiveSheet.Paste
Application.ScreenUpdating = True
End Sub
Не бойтесь совершенства. Вам его не достичь.
Страницы: 1
Наверх