Копирование значений с условиями в определенное место на другом листе

[Lohengrin]

Добрый день, коллеги!

Очень требуется помощь с макросом, не получается самому добиться результата(

Строки на листах Supply и Balance соответствуют гостиницам.
Макрос проверяет для каждой строки (гостиницы) листа Balance, есть ли ненулевые значения по столбцам на листе "Balance".
Дальше он должен вставлять их в лист "Supply" в свободные ячейки попарно в правильном порядке - сначала соединенную информацию из верхних ячеек (с 2 по 5) каждого столбца, потом собственно цифру по строке-гостинице. Результат виден сейчас на листе Supply, но что-то не полностью работает - подтягиваются не все цифры(

[Lohengrin]

Собственно файл

[DiemonStar]

выкладывайте пример вашего файла. и что вы хотите в итоге получить.

[Lohengrin]

Исходный файл выше, а в этом файле на листе Supply то, что нужно получить.

[Lohengrin]

Хм, никто не сможет помочь? Уважаемый DiemonStar ?

[Hugo121]

Геморойно макросом... Поэтому все и молчат.
Проще UDF написать - на вход что искать, где искать, и диапазон откуда тянуть данные.
Написать её как формулу массива - так сразу в весь диапазон (по строке) и вводить.
Если годится - возможно к понедельнику подумаю... пятница всёж

P.S. Единственное что смущает - а столбцов хватит? Вам на каждый столбец исходных данных нужно 2 столбца для результата - неувязочка может получиться...

[Lohengrin]

Если честно, я не понимаю, что такое UDF, но любое решение подойдет. Столбцов хватит, весь вопрос в том, насколько долго будет работать..
А не получится исправить в моем макросе какую-нибудь неправильную строку и все? он же почти работает))

Спасибо большое!

[Hugo121]

Ну можно и Ваш подкорректировать - добавил 2 строки, и одну передвинул, вроде всё
Но прошу учесть - это не мой код, я бы так не писал

Sub Macro2()
'
' Macro2 Macro
'

'
    Sheets("Balance").Activate
    Application.ScreenUpdating = False

    Dim j As Integer
    Dim k As Integer


    For k = 13 To 20
        NextColumn = 17 'Range("q3").End(xlUp).Column

        For j = 18 To 20


            Sheets("Balance").Activate
            If Cells(k, j) > 0 Then
                rez1 = Cells(k, j)
                rez2 = Cells(2, j) + "; " + Cells(3, j) + "; " + Cells(4, j) + "; " + Cells(5, j)

                Sheets("Supply").Activate


                Cells(k - 10, NextColumn) = rez2
                NextColumn = NextColumn + 1
                Cells(k - 10, NextColumn) = rez1
                NextColumn = NextColumn + 1


            End If

        Next j

    Next k

    Application.ScreenUpdating = True
End Sub

[Lohengrin]

Спасибо огромное!! вроде бы все работает) хороших выходных Вам!

[Hugo121]

И Вам спасибо! И хорошо отдохнуть! Погоды правда не обещают ещё пока