Страницы: 1
RSS
копирование с одного листа на другой при помощи диалогового окна
 
Здравствуйте, подскажить такой вот ответ на такой вот вопрос, нужно написать макрос, при запуске которого открывается диалоговое окно, где можно выбрать диапазон, затем он копируется на другой лист, к последней строке, что б не было пустых строк, и что б копировались только значания, нашел два макроса, но ни один не подходит, первый всегда тупо копирует только верхнюю строчку, втрой вообще не запускается
Код
Sub macroc2()
Application.ScreenUpdating = False
Dim i As Long
i = Sheets("лист1").Cells(Rows.Count, 4).End(xlUp).Row
Sheets("лист1").Range("D16:L" & i).Copy
i = Sheets("лист3").Cells(Rows.Count, 2).End(xlUp).Row + 1 'Îïðåäåëÿåì íèæ.Ñòðîêó
Sheets("лист3").Range("A" & i).Paste
Application.ScreenUpdating = True
End Sub
Код
Sub Macro1()
    Range("A1:P1").Copy
    Cells(Application.Max(25, Cells(Rows.Count, 1).End(xlUp)(2).Row), 1).PasteSpecial xlPasteValues
End Sub
макрос 1 в принципе подошел бы, если б конечно было копирование на другой лист, или выделения всего диапазона, или выделения ячейки, в которой строчке он находится, макрос 2 теоретически тоже подойдет, но не ясно как он работает
на листе 1 идут все рассчеты, на лист 3 должны попадать только скопированные значения
Изменено: denka1982 - 17.05.2022 15:47:20
 
Код
Sub ddd()
Set Sh = Sheets("Нужный лист")
x = Application.InputBox("Выделите дипазон для копирования", Type:=8)
Sh.Cells(Split(Sh.UsedRange.Address, "$")(4), 1).Offset(1).Resize(UBound(x), UBound(x, 2)).Value = x
End Sub
 
не работаеть(((ругается на эту строчку
Код
Sh.Cells(Split(Sh.UsedRange.Address, "$")(4), 1).Offset(1).Resize(UBound(x), UBound(x, 2)).Value = x
 
вы поменяли "Нужный лист" на имя вашего листа, куда нужно вставить данные выделенные через диалоговое окно?
 
да
 
тут он копирует в пределах одного листа, а нужно по идее с одного на другой
 
denka1982, добрый день.
Во вложении книга и макрос (запускать по Alt + F8). Откроется форма с выбором диапазона и листа для копирования
 
огромное спасибо, и еще вопрос, макрос сломался, вчера работал, сегодня ошибку начал выдавать, в чем может быть причина?
Код
Sub JoinRows()
Dim rng As Range, i, item, Dict, lCol As Long, lRow As Long
    Set Dict = CreateObject("Scripting.Dictionary")
    Set rng = Application.InputBox("Выберите диапазон", Type:=8)
    For Each i In rng.Rows
        item = Application.Transpose(Application.Transpose(i.Value2))
        Dict.Add i.Row, item
    Next i
    lCol = 1
    lRow = Worksheets("то что должно получиться").Cells(Rows.Count, 1).End(xlUp).Row + 1
    For Each item In Dict.items()
        Worksheets("то что должно получиться").Cells(lRow, lCol).Resize(1, UBound(item)) = item
        lCol = UBound(item) + lCol
    Next item
End Sub
выдает ошибку в этой строчке, до этого все было норм, хз что ему не нравится
Код
item = Application.Transpose(Application.Transpose(i.Value2))
 
denka1982, попробуйте так:
Код
Sub JoinRows()
Dim rng As Range, i, item, Dict, lCol As Long, lRow As Long
    Set Dict = CreateObject("Scripting.Dictionary")
    Set rng = Application.InputBox("Выберите диапазон", Type:=8)
    For Each i In rng.Rows
        item = i.Value2
        Dict.Add i.Row, item
    Next i
    lCol = 1
    lRow = Worksheets("то что должно получиться").Cells(Rows.Count, 1).End(xlUp).Row + 1
    For Each item In Dict.items()
        Worksheets("то что должно получиться").Cells(lRow, lCol).Resize(1, UBound(item, 2)) = item
        lCol = UBound(item, 2) + lCol
    Next item
End Sub
 
вопрос решен, но в чем была ошибка так и не понял, скорее всего связано с каким то другим форматом ячеек, вчера пытался настроить до двух значимых значений, возможно нарушил формат, сегодня вернул все как было, стало все работать, за помощь спасибо
 
написал:

Цитата
но в чем была ошибка так и не понял
denka1982
, возможно это связано с : https://excelvba.ru/code/Transpose
Страницы: 1
Наверх