Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Очередность копирования ячеек строки
 
#1
22.01.2017 15:42:57
Приветствую Вас гуру Excel. Есть макрос взятый с этого форума написанный  Юрий_М . Не много переделан.
Подскажите пожалуйста как переделать макрос что бы при копировании строки ячейки этой строки копировались в нужном порядке.
Например в таком:
Код
Sub spisok_gsm()
Application.ScreenUpdating = False
Dim LastRow As Long, Rw As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("Лист1")
        Rw = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        For i = 6 To LastRow
            If Cells(i, 11) <> " " Then
                Union(Cells(i, 1), Cells(i, 6), Cells(i, 7), Cells(i, 4), Cells(i, 2), Cells(i, 3), Cells(i, 5), Cells(i, 11), Cells(i, 15)).Copy .Cells(Rw, 1)
                Rw = Rw + 1
            End If
        Next
    End With
Application.ScreenUpdating = True
End Sub
 
 
 
#2
22.01.2017 15:47:51
Собирайте значения в нужном порядке в массив (кстати лучше тоже из массива, а не из ячеек), а затем выгружайте его сразу весь в нужное место
Согласие есть продукт при полном непротивлении сторон
 
 
 
#3
22.01.2017 15:53:43
Sanja, приветствую Вас. Дело в том что я не силен в VBA. Не могли бы Вы написать готовый макрос с вашими рекомендациями. Буду очень признателен Вам.
 
 
 
#4
22.01.2017 17:34:27
Приложите файл-пример или дайте ссылку на ту тему, в которой этот макрос Вам написали (если там есть файл)
Согласие есть продукт при полном непротивлении сторон
 
 
 
#5
23.01.2017 09:38:04
Sanja, извините что сразу не ответил вот ссылка и файл.
 
 
 
#6
23.01.2017 16:21:54
Код
Sub spisok_gsm()
Dim I&
Dim arrTemp()
arrVal = Range("A2:N" & Cells(Rows.Count, 1).End(xlUp).Row).Value
For I = 1 To UBound(arrVal)
    If arrVal(I, 11) <> Empty Then
        ReDim Preserve arrTemp(7, N)
        arrTemp(0, N) = arrVal(I, 5)
        arrTemp(1, N) = arrVal(I, 6)
        arrTemp(2, N) = arrVal(I, 3)
        arrTemp(3, N) = arrVal(I, 1)
        arrTemp(4, N) = arrVal(I, 2)
        arrTemp(5, N) = arrVal(I, 4)
        arrTemp(6, N) = arrVal(I, 10)
        arrTemp(7, N) = arrVal(I, 14)
        N = N + 1
    End If
Next
With Worksheets("Результат")
    .Range("A2:H" & .Cells(.Rows.Count, 1).End(xlUp).Row).ClearContents
    .Range("A2").Resize(N, 8) = Application.Transpose(arrTemp)
    .Cells.EntireColumn.AutoFit 'автоботбор ширины столбцов, если не нужен можно удалить строку
End With
End Sub
Изменено: Sanja - 23.01.2017 16:45:49
Согласие есть продукт при полном непротивлении сторон
 
 
 
#7
24.01.2017 10:25:07
Sanja,спасибо большое все работает.
 
 
 
#8
24.01.2017 10:51:14
Sanja, подскажите пожалуйста что изменить в вашем макросе что бы он добавлял данные вниз к уже имеющимся, а не очищал таблицу на листе "Результат".
 
 
 
#9
24.01.2017 10:56:54
Код
Sub spisok_gsm()
Dim I&
Dim arrTemp()
arrVal = Range("A2:N" & Cells(Rows.Count, 1).End(xlUp).Row).Value
For I = 1 To UBound(arrVal)
    If arrVal(I, 11) <> Empty Then
        ReDim Preserve arrTemp(7, N)
        arrTemp(0, N) = arrVal(I, 5)
        arrTemp(1, N) = arrVal(I, 6)
        arrTemp(2, N) = arrVal(I, 3)
        arrTemp(3, N) = arrVal(I, 1)
        arrTemp(4, N) = arrVal(I, 2)
        arrTemp(5, N) = arrVal(I, 4)
        arrTemp(6, N) = arrVal(I, 10)
        arrTemp(7, N) = arrVal(I, 14)
        N = N + 1
    End If
Next
With Worksheets("Результат")
    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    .Range("A" & lRow).Resize(N, 8) = Application.Transpose(arrTemp)
    .Cells.EntireColumn.AutoFit 'автоботбор ширины столбцов, если не нужен можно удалить строку
End With
End Sub
Согласие есть продукт при полном непротивлении сторон
 
 
 
#10
24.01.2017 11:02:46
Sanja, еще раз спасибо Вам большое. Очень выручили. Вопросов больше нет.
 
 
 
Страницы: 1
Наверх