Помогите составить сложный Макрос

[Сергей Саныч]

отдельное спасибо за макросы alex77755 & kalbasiatka!!! Большое спасибо, вы человеки!!

[Сергей Саныч]

kalbasiatka а во вложении макрос должен был быть или нет ?)))) открыл excel а макроса в нем нет(((

[FiataliS]

Сообщение от Сергей Саныч

kalbasiatka а во вложении макрос должен был быть или нет ?)))) открыл excel а макроса в нем нет(((

Вот такой там макрос написан в Module1

Option Explicit

Sub QWERT()
Dim M1(), M2(), M3(), R, i
Dim T, S() As String
Dim MARSH: Set MARSH = CreateObject("Scripting.Dictionary")
Dim CD: Set CD = CreateObject("Scripting.Dictionary")
M1 = Лист1.Range("A1:D" & Лист1.Range("A1").End(xlDown).Row)
M2 = Лист2.Range("A1:E" & Лист2.Range("A1").End(xlDown).Row)
M3 = Лист3.Range("A1:E" & Лист3.Range("A1").End(xlDown).Row)

For R = 2 To UBound(M2)
    MARSH.Item(M2(R, 5)) = M2(R, 4)
Next R

For R = 2 To UBound(M3)
    T = M3(R, 1) & ";" & M3(R, 3) & ";" & M3(R, 4)
    CD.Item(T) = T & ";" & M3(R, 5)
Next R
Лист4.Cells.ClearContents

With Лист4
    For R = 2 To UBound(M1)
        T = MARSH.Item(M1(R, 2)) & ";" & M1(R, 3) & ";" & M1(R, 4)
        S = Split(CD.Item(T), ";")
        .Cells(R, 1) = MARSH.Item(M1(R, 2))
        .Cells(R, 2) = M1(R, 2)
        .Cells(R, 3) = S(1)
        .Cells(R, 4) = S(2)
        .Cells(R, 5) = S(3)
    Next R
End With
End Sub

[Сергей Саныч]

спасибо большое всем!

[kalbasiatka]

Вот такой там макрос написан в Module1

Не совсем ) А даже совсем не то )))

[Сергей Саныч]

Ну так все таки, там его нет..... хорошо у меня последний вопрос kalbasiatka будете его публиковать или нет, чтобы просто я Вас больше не тревожил?
мне он очень нужен.... буду сильно признателен Вам за помощь...

[kalbasiatka]

А макрос alex77755 не подошёл ? Для чего человек время тратил?

[Сергей Саныч]

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

А макрос alex77755 не подошёл ? Для чего человек время тратил?

Я alex77755 сильно благодарен за его работу и у него работает все нормально, просто не понимаю вашего поведения kalbasiatka, если вы не хотите помогать, а просто высказать свое мнение, пишите тогда так, что я просто высказал свое мнение, и не буду делать за вас! никто же вас не обвиняет в том что вы не помогаете бездарю, человеку который попрошайничает, и которому в отличии от Вас это тяжело сделать!Передумали так передумали!!пережевем!

[Сергей Саныч]

Еще раз хотел поблагодарить всех участников этого топика, за проделанные работы и потраченное время!! для меня это большое дело, и вы облегчили мне жизнь!!)

[Сергей Саныч]

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

Вот такой там макрос написан в Module1

Option Explicit

Sub QWERT()
Dim M1(), M2(), M3(), R, i
Dim T, S() As String
Dim MARSH: Set MARSH = CreateObject("Scripting.Dictionary")
Dim CD: Set CD = CreateObject("Scripting.Dictionary")
M1 = Лист1.Range("A1:D" & Лист1.Range("A1").End(xlDown).Row)
M2 = Лист2.Range("A1:E" & Лист2.Range("A1").End(xlDown).Row)
M3 = Лист3.Range("A1:E" & Лист3.Range("A1").End(xlDown).Row)

For R = 2 To UBound(M2)
    MARSH.Item(M2(R, 5)) = M2(R, 4)
Next R

For R = 2 To UBound(M3)
    T = M3(R, 1) & ";" & M3(R, 3) & ";" & M3(R, 4)
    CD.Item(T) = T & ";" & M3(R, 5)
Next R
Лист4.Cells.ClearContents

With Лист4
    For R = 2 To UBound(M1)
        T = MARSH.Item(M1(R, 2)) & ";" & M1(R, 3) & ";" & M1(R, 4)
        S = Split(CD.Item(T), ";")
        .Cells(R, 1) = MARSH.Item(M1(R, 2))
        .Cells(R, 2) = M1(R, 2)
        .Cells(R, 3) = S(1)
        .Cells(R, 4) = S(2)
        .Cells(R, 5) = S(3)
    Next R
End With
End Sub

а можно вопрос задать по этому макросу, после того как он находит одно совпадение строки с первого листа с третьим листом, он перестает искать , а ведь на третьем листе совпадений может быть больше чем одно, как это можно подправить? подскажите пожалуйста??....