макрос.Чтение данных из 1 табл и результат действия в 2 таблице.

[igsxor]

Добрый день.
Подскажите пожалуйста каким способом можно решить данный вопрос.
Из 1ой таблицы нужно выбрать данные из столбца rashod(данные суммируются между собой по отдельному человеку(целочисленный тип данных numls),суммируются отдельно синие строки и отдельно красные.

Файлы Excel прикреплены к письму.В 2 ой таблице примерный результат,то что нужно получить,если такое возможно,конечно.Представленные примеры урезанные,т.к. таблицы состоят из более 300 строк.

Если такой способ возможен,подскажите как реализовать его.

[igsxor]

Прошу прощения забыл прикрепить файл.
архив винрар,excel 2007

[Hugo121]

Чувствую, за основу можно взять этот код:

http://www.planetaexcel.ru/forum.php?thread_id=24221
с помощью Николая
Option Explicit

Sub Otbor()
    Dim a(), b, cc, oDict As Object, i As Long, ii As Long, j As Long, k As Long, temp As String

    a = Range("B2:D" & Range("B" & Rows.Count).End(xlUp).Row).Value
    ReDim b(1 To UBound(a), 1 To 3)

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a)
            temp = IIf(Trim(a(i, 2)) < Trim(a(i, 3)), UCase(Trim(a(i, 2)) & "|" & Trim(a(i, 3))), UCase(Trim(a(i, 3)) & "|" & Trim(a(i, 2))))
            If Not .Exists(temp) Then
                j = j + 1: .Item(temp) = j
                b(j, 1) = Split(temp, "|")(0)
                b(j, 2) = Split(temp, "|")(1)
                b(j, 3) = a(i, 1)
            Else
                k = .Item(temp)
                b(k, 3) = b(k, 3) + a(i, 1)
            End If
        Next
    End With

    With ThisWorkbook.Worksheets(1)
        .Range("L5:n5").Resize(UBound(b)) = b
    End With

End Sub

Пример переложите - там даже не 300, а 2 раза по 7300 строк

[Hugo121]

Вот так например (подготовьте чистый второй лист):

Option Explicit

Sub Otbor()
    Dim a(), b, cc, oDict As Object, i As Long, ii As Long, j As Long, k As Long, temp As String

    a = Range("A2:I" & Range("A" & Rows.Count).End(xlUp).Row).Value
    ReDim b(1 To UBound(a), 1 To 3)

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a)
            temp = a(i, 1) & "|" & a(i, 5)
            If Not .Exists(temp) Then
                j = j + 1: .Item(temp) = j
                b(j, 1) = Split(temp, "|")(0)
                b(j, 2) = Split(temp, "|")(1)
                b(j, 3) = a(i, 9)
            Else
                k = .Item(temp)
                b(k, 3) = b(k, 3) + a(i, 9)
            End If
        Next
    End With

    With ThisWorkbook.Worksheets(2)
        .Range("A1:C1").Resize(j) = b
    End With

End Sub

Выход немного отличается от заказанного, но сейчас подгонять некогда.

[igsxor]

Спасибо,перепутал когда формулировал вопрос.

[Hugo121]

Исправил в коде выше выгрузку - не Resize(UBound(b)) , а Resize(j)
Так лучше, хотя результат с виду не изменился.
Сейчас глянул - там "|" и Split лишнее, можно и без этого обойтись:

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a)
            temp = a(i, 1) & a(i, 5)
            If Not .Exists(temp) Then
                j = j + 1: .Item(temp) = j
                b(j, 1) = a(i, 1)
                b(j, 2) = a(i, 5)
                b(j, 3) = a(i, 9)
            Else
                k = .Item(temp)
                b(k, 3) = b(k, 3) + a(i, 9)
            End If
        Next
    End With

, но пусть...

[igsxor]

Сообщение от Hugo121

Исправил в коде выше выгрузку - не Resize(UBound(b)) , а Resize(j)
Так лучше, хотя результат с виду не изменился.

А какой именно код использовать?
И если Вас не затруднит прокоментировать,то что он делает.
Дело в том,что только только начал читать книгу по VB Excel Peter Aitken.

[Hugo121]

Через пару часов могу прокомментировать.

[igsxor]

Сообщение от Hugo121

Исправил в коде выше выгрузку - не Resize(UBound(b)) , а Resize(j)
Так лучше, хотя результат с виду не изменился.
Сейчас глянул - там "|" и Split лишнее, можно и без этого обойтись:

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a)
            temp = a(i, 1) & a(i, 5)
            If Not .Exists(temp) Then
                j = j + 1: .Item(temp) = j
                b(j, 1) = a(i, 1)
                b(j, 2) = a(i, 5)
                b(j, 3) = a(i, 9)
            Else
                k = .Item(temp)
                b(k, 3) = b(k, 3) + a(i, 9)
            End If
        Next
    End With

, но пусть...

Записал макрос,но при исполнении редактор VB выдаёт ошибку:

Option Explicit
Sub Otbor()
'
' Viborka_hc Ìàêðîñ
' Âûáèðàåò è ñóììèðóåò çíà÷åíèÿ ïîêàçàòåëåé ãîð è õîë âîäû
'
    Dim a(), b, cc, oDict As Object, i As Long, ii As Long, j As Long, k As Long, temp As String

    a = Range("A2:I" & Range("A" & Rows.Count).End(xlUp).Row).Value
    ReDim b(1 To UBound(a), 1 To 3)

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a)
            temp = a(i, 1) & a(i, 5)
            If Not .Exists(temp) Then
                j = j + 1: .Item(temp) = j
                b(j, 1) = a(i, 1)
                b(j, 2) = a(i, 5)
                b(j, 3) = a(i, 9)
            Else
                k = .Item(temp)
                b(k, 3) = b(k, 3) + a(i, 9)
            End If
        Next
    End With
'
' Application.Run "PERSONAL.XLSB!Viborka_hc"
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Documents and Settings\dell_xp\Application Data\Microsoft\Excel\XLSTART\PERSONAL.XLSB" _
        , FileFormat:=xlExcel12, CreateBackup:=False
    Application.Left = 214
    Application.Top = 25.75
End Sub

[Hugo121]

Не понятно, зачем сохранять, да и ещё как XLSTART\PERSONAL.XLSB?
И самое главное выкинули - где выгрузка полученного массива?