Страницы: 1
RSS
Оптимизация кода VBA (перенос данных с одного листа на другой с заданным шагом (через определённое количество строк)
 
Здравствуйте.
Код сделан макрорекордером.
Перенос данных с листа 1 на лист 2 в определённые ячейки и с определённым шагом.
Пример выложен на 2 страницы (печатные)
Страниц может быть и 100, и моё детище получается громоздки.
Уважаемые специалисты как можно упростить код.

Код
'Страница 1
Worksheets("1").Range("A1:A60").Copy
Worksheets("2").Range("D4").PasteSpecial Paste:=xlPasteValues
Worksheets("1").Range("B1:B60").Copy
Worksheets("2").Range("C4").PasteSpecial Paste:=xlPasteValues
Worksheets("1").Range("C1:C60").Copy
Worksheets("2").Range("G4").PasteSpecial Paste:=xlPasteValues
Worksheets("1").Range("D1:D60").Copy
Worksheets("2").Range("L4").PasteSpecial Paste:=xlPasteValues
Worksheets("1").Range("E1:E60").Copy
Worksheets("2").Range("J4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("1").Select 'удаляем 60 строк
    Rows("1:60").Select
    Selection.Delete Shift:=xlUp
Do While Range("B1").Offset(LineCt, 0) = UCase(LineOfText)

Call SHel
Exit Sub
Loop

'Страница 2
Worksheets("1").Range("A1:A60").Copy
Worksheets("2").Range("D75").PasteSpecial Paste:=xlPasteValues
Worksheets("1").Range("B1:B60").Copy
Worksheets("2").Range("C75").PasteSpecial Paste:=xlPasteValues
Worksheets("1").Range("C1:C60").Copy
Worksheets("2").Range("G75").PasteSpecial Paste:=xlPasteValues
Worksheets("1").Range("D1:D60").Copy
Worksheets("2").Range("L75").PasteSpecial Paste:=xlPasteValues
Worksheets("1").Range("E1:E60").Copy
Worksheets("2").Range("J75").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("1").Select 'удаляем 60 строк
    Rows("1:60").Select
    Selection.Delete Shift:=xlUp
Do While Range("B1").Offset(LineCt, 0) = UCase(LineOfText)
Call SHel
Exit Sub
Loop

Call Выход
 
1. Поменять
Код
Worksheets("1")...
на
Код
Dim sh1 As Worksheet
Set sh1 = Worksheets("1")
и использовать далее эту переменную.

2. Цикл Do вообще непонятен. Где переменная, которая будет создавать цикл? И вообще этот цикл будет выполняться не более одного раза, так как после SHel сразу идёт Exit Sub.

3. Выделять ничего не надо. Поменять:
Код
Sheets("1").Select 'удаляем 60 строк
Rows("1:60").Select
Selection.Delete Shift:=xlUp
на
Код
sh1.Rows("1:60").Delete xlUp
There is no knowledge that is not power
 
Если нужны только значения ячеек, то можно как-то так:
Код
Set ws1 = Worksheets("1")
Set ws2 = Worksheets("2")
ws2.Range("....").Value = ws1.Range("....").Value
.....
ws1.Rows("....").Delete Shift:=xlUp
Изменено: MaxM - 05.05.2016 09:40:42
 
Цикл DO, проверяет на листе 1 в ячейке B1 есть ли текст
Если есть, идём дальше (стр 2-3-4-5....), нет выходим
Спасибо за отклики
Буду кумекать
 
В продолжение темы.

Почему то код не работает:
Код
Sub CopyPaste()

    iLastRow = Worksheets("Name2").Cells(Rows.Count, 1).End(xlUp).Row
    iLastColumn = Worksheets("Name2").Cells.SpecialCells(xlLastCell).Column
Worksheets("Name1").Range(Cells(1, 1), Cells(iLastRow, iLastColumn)).Value = _
Worksheets("Name2").Range(Cells(1, 1), Cells(iLastRow, iLastColumn)).Value

End Sub
Задача простая, взять все данные с листа Name2 и перенести их Name1.

Выдает ошибку. Не понимаю что не так.
невозможное делаем сразу, чудо - требует небольшой подготовки.
 
Код
Sub CopyPaste()
    Dim lrow&, lcolumn&
    Dim sh1 As Worksheet, sh2 As Worksheet
    Set sh1 = Worksheets("Name1"): Set sh2 = Worksheets("Name2")
    With sh2
        lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lcolumn = .Cells.SpecialCells(xlLastCell).Column
        sh1.[a1].Resize(lrow, lcolumn).Value = .Range(.[a1], .Cells(lrow, lcolumn)).Value
    End With
End Sub


Вариант перенесения всего диапазона с помощью массива

Код
Sub CopyPaste()
    Dim lrow&, lcolumn&, arr()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Set sh1 = Worksheets("Name1"): Set sh2 = Worksheets("Name2")
    With sh2
        arr = .UsedRange.Value
        sh1.[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    End With
End Sub
Изменено: Nordheim - 16.05.2019 09:39:02
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim,
спасибо.
Массивом просто то что нужно!
Изменено: phelex - 16.05.2019 09:49:20
невозможное делаем сразу, чудо - требует небольшой подготовки.
Страницы: 1
Наверх