Страницы: 1
RSS
Макрос наподобие ИНДЕКС для разнесения значений по разным листам внутри одной книги
 
Коллеги приветствую!

Появилась нетривиальная задача, но сам  не решил, прошу помочь.
Нужно разнести из листа со сценариями значения по другим листам в зависимости от нескольких условий - дата, флаг сценария и наименование листа.
Думаю все станет понятно из примера.

Спасибо!

P.S. Изначально задача была решена через формулы, но поскольку строк в каждом листе несколько тысяч книга стала сильно тормозить, почему и потребовалось макросовое решение.  
чтоб дело мастера боялось, он знает много страшных слов.
 
Ri Yu,
Код
Sub mrshkei()
Dim arr, i As Long, sh As Worksheet, lr As Long, sh2 As Worksheet
Set sh = Worksheets("Лист1")
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
arr = sh.Range("A5:D" & lr)
For i = LBound(arr) To UBound(arr)
    Set sh2 = Worksheets(arr(i, 2))
    If arr(i, 1) <> 0 Then
        sh2.Cells(arr(i, 3) - sh2.Cells(5, 1) + 5, 2) = arr(i, 4)
    End If
Next i
End Sub
Не бойтесь совершенства. Вам его не достичь.
 
Код
Sub Разнести()
    Dim sh1 As Worksheet
    Set sh1 = Worksheets("Лист1")
    
    Dim arr As Variant
    Dim orr As Variant
    Dim y As Long
    With sh1
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range(.Cells(1, 1), .Cells(y, 4))
        ReDim orr(1 To y, 1 To 1)
    End With
    
    Dim shA As Worksheet
    Dim u As Long
    For y = 5 To UBound(arr, 1)
        If arr(y, 1) = 1 Then
            Set shA = Nothing
            On Error Resume Next
            Set shA = Worksheets(arr(y, 2))
            On Error GoTo 0
            If shA Is Nothing Then
                orr(y, 1) = "нет листа"
            Else
                u = 0
                On Error Resume Next
                'u = WorksheetFunction.Match(arr(y, 3), shA.Columns(1), 0)
                With sh1.Cells(y, 5)
                    .FormulaR1C1 = "=MATCH(RC3,'" & arr(y, 2) & "'!C1,0)"
                    u = .Value
                    .Clear
                End With
                On Error GoTo 0
                
                If u = 0 Then
                    orr(y, 1) = "нет даты"
                Else
                    shA.Cells(u, 2).Value = arr(y, 4)
                    orr(y, 1) = "ok"
                End If
            End If
        End If
    Next
    sh1.Range("E1").Resize(UBound(orr, 1), 1) = orr
End Sub
 
Код
Sub Macro1()
Dim LastRow As Long, i As Long, Rng As Range
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 5 To LastRow
        If Cells(i, 1) = 1 Then
            With Sheets(Cells(i, 2).Value)
                Set Rng = .Columns(1).Find(what:=Cells(i, 3), LookIn:=xlValues, LookAt:=xlWhole)
                If Not Rng Is Nothing Then
                    Rng.Offset(0, 1) = Cells(i, 4)
                End If
            End With
        End If
    Next
End Sub
 
Супер! Ребята вы космические!!!
Спасибо!!
чтоб дело мастера боялось, он знает много страшных слов.
 
Пару вопросов:
1. А если в листах, на которые нужно разносить это не всегда столбец B ?
2. И можно ли в процессе нового пересчета (изменились даты/флаги) удалять ранее внесенные значения?  
чтоб дело мастера боялось, он знает много страшных слов.
 
1. Нужно указывать номер столбца или объяснить логику, по которой вычислять этот номер.
2. Можно.
 
Цитата
2. И можно ли в процессе нового пересчета (изменились даты/флаги) удалять ранее внесенные значения?  
просто предварительно очищать все данные, но опять же
Цитата
Юрий М написал:
Нужно указывать номер столбца или объяснить логику, по которой вычислять этот номер.
что бы его очистить
Не бойтесь совершенства. Вам его не достичь.
 
По поводу разных столбцов: как вариант, добавить в таблицу на первом листе номера столбцов.
 
Этот вариант по условию из сообщения #1.
Полагаю, будет работать быстрее, чем вариант из сообщения #3.
Код
Sub Разнести()
    Dim sh1 As Worksheet
    Set sh1 = Worksheets("Лист1")
    
    Dim arr As Variant
    Dim brr As Variant
    Dim orr As Variant
    Dim y As Long
    With sh1
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range(.Cells(1, 1), .Cells(y, 4))
        ReDim orr(1 To y, 1 To 1)
    End With
    
    Dim dic As Object
    Dim dicU As Object
    Set dicU = CreateObject("Scripting.Dictionary")
    
    Dim shA As Worksheet
    Dim u As Long
    For y = 5 To UBound(arr, 1)
        If arr(y, 1) = 1 Then
            Set shA = Nothing
            On Error Resume Next
            Set shA = Worksheets(arr(y, 2))
            On Error GoTo 0
            If shA Is Nothing Then
                orr(y, 1) = "нет листа"
            Else
                If Not dicU.Exists(arr(y, 2)) Then
                    Set dicU.Item(arr(y, 2)) = CreateObject("Scripting.Dictionary")
                    With shA
                        u = .Cells(.Rows.Count, 1).End(xlUp).Row
                        brr = .Range(.Cells(1, 1), .Cells(u, 2))
                    End With
                    dicU.Item(arr(y, 2)).Item("array") = brr
                    For u = 5 To UBound(brr, 1)
                        dicU.Item(arr(y, 2)).Item(brr(u, 1)) = u
                    Next
                End If
            
                Set dic = dicU.Item(arr(y, 2))
                brr = dic.Item("array")
                
                If dic.Exists(arr(y, 3)) Then
                    u = dic.Item(arr(y, 3))
                Else
                    u = 0
                End If
                
                If u = 0 Then
                    orr(y, 1) = "нет даты"
                Else
                    'shA.Cells(u, 2).Value = arr(y, 4)
                    brr(u, 2) = arr(y, 4)
                    dicU.Item(arr(y, 2)).Item("array") = brr
                    orr(y, 1) = "ok"
                End If
            End If
        End If
    Next
    
    For y = 0 To dicU.Count - 1
        brr = dicU.Items()(y).Item("array")
        Sheets(dicU.Keys()(y)).Cells(1).Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    Next
    
    sh1.Range("E1").Resize(UBound(orr, 1), 1) = orr
End Sub
 
Спасибо за ответы! Сколько времени сэкономлено!

Все же, Юрий М,  прав если указать номер столбца - это будет окончательным решением.
Очистка не нужна.  
чтоб дело мастера боялось, он знает много страшных слов.
 
Код
Sub Разнести()
    Dim sh1 As Worksheet
    Set sh1 = Worksheets("Лист1")
     
    Dim arr As Variant
    Dim brr As Variant
    Dim bbr As Variant
    Dim orr As Variant
    Dim y As Long
    Dim x As Integer
    With sh1
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range(.Cells(1, 1), .Cells(y, 5))
        ReDim orr(1 To y, 1 To 1)
    End With
     
    Dim dic As Object
    Dim dicU As Object
    Set dicU = CreateObject("Scripting.Dictionary")
     
    Dim shA As Worksheet
    Dim u As Long
    For y = 5 To UBound(arr, 1)
        If arr(y, 1) = 1 Then
            Set shA = Nothing
            On Error Resume Next
            Set shA = Worksheets(arr(y, 2))
            On Error GoTo 0
            If shA Is Nothing Then
                orr(y, 1) = "нет листа"
            Else
                If Not dicU.Exists(arr(y, 2)) Then
                    Set dicU.Item(arr(y, 2)) = CreateObject("Scripting.Dictionary")
                    With shA
                        x = arr(y, 3)
'                        On Error Resume Next
'                        x = WorksheetFunction.Match("Значение", .Rows(4), 0)
'                        On Error GoTo 0
                    
                        u = .Cells(.Rows.Count, 1).End(xlUp).Row
                        brr = .Range(.Cells(1, 1), .Cells(u, 1 - (u = 1)))
                        ReDim bbr(1 To u, 1 To 1)
                        bbr(4, 1) = "Значение"
                    End With
                    dicU.Item(arr(y, 2)).Item("array") = bbr
                    dicU.Item(arr(y, 2)).Item("x") = x
                    For u = 5 To UBound(brr, 1)
                        dicU.Item(arr(y, 2)).Item(brr(u, 1)) = u
                    Next
                End If
             
                Set dic = dicU.Item(arr(y, 2))
                brr = dic.Item("array")
                 
                If dic.Exists(arr(y, 4)) Then
                    u = dic.Item(arr(y, 4))
                Else
                    u = 0
                End If
                 
                If u = 0 Then
                    orr(y, 1) = "нет даты"
                Else
                    brr(u, 1) = arr(y, 5)
                    dicU.Item(arr(y, 2)).Item("array") = brr
                    orr(y, 1) = "ok"
                End If
            End If
        End If
    Next
     
    For y = 0 To dicU.Count - 1
        x = dicU.Items()(y).Item("x")
        If x > 0 Then
            brr = dicU.Items()(y).Item("array")
            Sheets(dicU.Keys()(y)).Cells(1, x).Resize(UBound(brr, 1), UBound(brr, 2)) = brr
        End If
    Next
     
    sh1.Range("F1").Resize(UBound(orr, 1), 1) = orr
End Sub
 
Код
Sub Macro1()
Dim LastRow As Long, i As Long, Rng As Range, iCol As Long
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 5 To LastRow
        If Cells(i, 1) = 1 Then
            iCol = Cells(i, 3) - 1
            With Sheets(Cells(i, 2).Value)
                Set Rng = .Columns(1).Find(what:=Cells(i, 4), LookIn:=xlValues, LookAt:=xlWhole)
                If Not Rng Is Nothing Then
                    Rng.Offset(0, iCol) = Cells(i, 5)
                End If
            End With
        End If
    Next
End Sub
Страницы: 1
Наверх