Страницы: 1
RSS
Можно ли преобразовать вертикальный массив в строку, заставить негра улыбнуться
 
Доброе  время суток уважаемые форумчане. Примите мое глубочайшее уважение за проявленный к моей теме интерес.  Итак, к условиям.
Столбцы базы:  1- наименование материала,2 - 5 номер госта соответствующего базе ( гостов для 1го материала может быть от 1 до 5).
Столбы ежедневно вбиваемые вручную: номер пункта и  наименование материала.
Кнопка получения результатов, позаимствованная здесь на форуме в виде грустящего негра
Строка результата: номер пункта - должен тащиться из таблица вбитой вручную. и номер госта - должен тащиться (снова простите за термин)) из базы, с учетом того, что для указанного пункта определен материал для которого уже установлено соответствие госта в базе.  Также,   есть условие- если для материала два или более гостов, то в результатах второй пункт и второй гост должны появляться только после перечисления в строке всего первого ряда пунктов.

Прошу прощения если не понятно, вопросы  ускорят  решение. как на самом деле хотел бы увидеть-в  примере.
С уважением Антон
 
На скорую руку
Код
Sub GOST()
Dim arr(), arrTR()
Dim I&, J&, N&
With Worksheets("Лист1")
    arr = .Range("B3:H" & .Cells(.Rows.Count, "H").End(xlUp).Row).Value
    ReDim arrTR(UBound(arr) * UBound(arr, 2))
    For J = 1 To UBound(arr, 2) - 1
        For I = 1 To UBound(arr, 1)
            If arr(I, J) <> Empty Then
                arrTR(N) = arr(I, 7): N = N + 1
                arrTR(N) = arr(I, J): N = N + 1
            End If
        Next
    Next
    .Range("K4").Resize(, N) = arrTR
End With
End Sub
Изменено: Sanja - 12.02.2018 20:49:24
Согласие есть продукт при полном непротивлении сторон
 
Здравствуйте! Еще вариант:
Код
Sub Perenos()
    ThisWorkbook.Worksheets("База").Activate
    Dim lRow  As Long
    Dim lCol As Long
    Dim lCol_1 As Long
    lCol = 2
    lCol_1 = 11
For lCol = 2 To 7
 For lRow = 3 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(Rows.Count, lCol).End(xlUp).Row = 2 Then
       Exit Sub
    End If
    If Cells(lRow, lCol) = "" Then
       lRow = lRow + 1
    End If
    If Cells(lRow, 2) <> "" Then
       Cells(3, lCol_1) = Cells(lRow, 8)
       Cells(3, lCol_1 + 1) = Cells(lRow, lCol)
    End If
       lCol_1 = lCol_1 + 2
 Next lRow
Next lCol
End Sub
 
Код
lCnt = Application.CountIf(.Range("B3:G" & .Cells(.Rows.Count, "H").End(xlUp).Row), "<>")

Это к первому коду, чтобы не менять размерность arrTR в цикле.
Или задать размерность по максимуму
Код
 lCnt = UBound(arr) * UBound(arr, 2)

но выгружать по N
 
vikttur, Спасибо. Изменил код Выше с учетом рекомендаций
Изменено: Sanja - 12.02.2018 20:49:54
Согласие есть продукт при полном непротивлении сторон
 
Цитата
Sanja написал:
Спасибо. Изменил код Выше с учетом рекомендаций
Sanja- СПАСИБО!!! Это просто выше всяких похвал. Как раз то что мне нужно, я все проверил, насколько я разобрался в Вашем примере то все работает. Скажите, в моем примере уже файл с учетом Вашей последней ремарки?
 
Цитата
_Igor_61 написал:
Здравствуйте! Еще вариант:
Низкий поклон Вам, все действительно работает! Спасибо
 
Цитата
vikttur написал:
Это к первому коду
Спасибо
 
Да, файл, приложенный в сообщении #2, с учетом всех изменений
Согласие есть продукт при полном непротивлении сторон
 
Цитата
Sanja написал:
Да, файл, приложенный в сообщении #2, с учетом всех изменений
Еще раз спасибо. Можно ли внести еще одну самую маленькую ремарку? Нужно чтобы для результата применялся автоподбор по ширине столбца  и чтобы база оставалась на 1 листе а поле вставки и результат на втором )) простите за капризы
Изменено: Antoni San - 13.02.2018 14:44:10
 
Цитата
Antoni San написал: для результата применялся автоподбор по ширине столбца...и результат на втором листе
Код
Sub GOST()
Dim arr(), arrTR()
Dim I&, J&, N&
With Worksheets("Лист1")
    arr = .Range("B3:H" & .Cells(.Rows.Count, "H").End(xlUp).Row).Value
    ReDim arrTR(UBound(arr) * UBound(arr, 2))
    For J = 1 To UBound(arr, 2) - 1
        For I = 1 To UBound(arr, 1)
            If arr(I, J) <> Empty Then
                arrTR(N) = arr(I, 7): N = N + 1
                arrTR(N) = arr(I, J): N = N + 1
            End If
        Next
    Next
End With
Application.ScreenUpdating = False
With Worksheets("Лист2")
    .Range("A1").Resize(, N) = arrTR
    .Rows(1).EntireColumn.AutoFit
    .Activate
End With
Application.ScreenUpdating = True
End Sub
Согласие есть продукт при полном непротивлении сторон
 
Цитата
Sanja написал:
Согласие есть продукт при полном непротивлении сторон.
Простите за навязчивость, по условиям : "поле вставки и результат на втором )) ..."..безуспешно попробовал сам подправить ..увы и ах..

Вот пример.

И вот еще, далее этот список хочу объединить в одну ячейку, есть уже и макрос, только вопрос, обязательно ли нужно два макроса для двух кнопок или можно в одном макросе сделать две кнопки добавив к содержимому первого макроса начинку второго.  
Изменено: Antoni San - 13.02.2018 15:35:39
Страницы: 1
Наверх