Страницы: 1
RSS
Перенос данных с одного листа на другой, макрос
 
Уважаемые форумчане!
Помогите пожалуйста с написанием макроса, который по условию переносит данные с одного листа на другой.
Более детально указано в приложенном файле.

Заранее спасибо!
С уважением,
sbirliko
 
А самому что-нить сделать, хоть макрорекордером? А поиск потерзать? Уж столько напереносили по условию, неинтересно. А стол заказов в разделе Работа.
Я сам - дурнее всякого примера! ...
 
Несмотря на то, что я полностью согласен с KuklP, вот код:
Код
Sub tt()
Dim L As Long: L = 3
Application.ScreenUpdating = False
With Sheets("History_")
.Unprotect
.Range("B3:I" & Cells(Rows.Count, 2).End(xlUp)).Clear
End With
Sheets("Action-Log").Activate
For I = 3 To Cells(Rows.Count, 2).End(xlUp).Row
If Cells(I, 11) = "Выполнен" Then
Range("C" & I & ":H" & I).Copy Destination:=Sheets("History_").Range("C" & L)
Range("K" & I).Copy Destination:=Sheets("History_").Range("I" & L)
With Sheets("History_").Cells(L, 2)
    .Value = L - 2
    .Borders.LineStyle = 1
End With
L = L + 1
End If
Next I
Sheets("History_").Protect
Application.ScreenUpdating = True
End Sub



 
KuklP добрый день.

к сожалению своих извилин не хватает.. даже на редактирование макросов с других примеров, которые были найдены с помощью поиска..
для примера
Код
Sub Запрос()'
    Sheets("Лист2";).Select
    Range("B2";).Select
    ActiveCell.FormulaR1C1 = _
        "=IF(ISNA(VLOOKUP(RC[-1],Лист1!R1C3:R1000C6,4,0)),"""",VLOOKUP(RC[-1],Лист1!R1C3:R1000C6,4,0))"
    Range("B2";).Select
    Selection.Copy
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    ActiveSheet.Paste
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1";).Select
    Application.CutCopyMode = False
End Sub

и Sub Perenos()Dim iLastRow As Long
    iLastRow = Range("A8";).End(xlDown).Row
        Range("A8:F" & iLastRow).Copy _
        Sheets("База";).Range("A" & Sheets("База";).Cells(Rows.Count, 1).End(xlUp).Row + 1)
End Sub

а сделать это через макроредактор сложно, т.к. я не знаю как создать привязку к условию(то что указано в примере)

ну уж простите, если это тема уже приелась...
 
sbirliko, не расстраивайтесь и оформите код макроса как положено (кнопка <...>). Макрос я написал по Вашим таблицам, попробуйте
 
МВТ, Спасибо большое! Но, кажется ваш код написан вовсе не макроредактором....)))
И еще один момент, возможно ли удаление строк из листа Action-Log, которые были перенесены на лист History_?
 
sbirliko, я и не говорил, что рекордером :). Да строки можно удалять, вставлять или менять: после окончания работы макроса таблицы никак друг с другом не связаны. Таблица-результат не имеет ссылок на Таблицу-источник, макрос просто снимает защиту, копирует отобранную информацию на другой лист и снова ставит защиту.  
 
Вариант:
Код
Sub www()
    Sheets("History_").Unprotect "123"
    Sheets("History_").UsedRange.ClearContents
    With Sheets("Action-Log").Range("B2").CurrentRegion
        .AutoFilter 10, "Выполнен"
        .Copy Sheets("History_").Range("B2")
        .Parent.AutoFilterMode = 0
    End With
    Sheets("History_").Protect "123"
End Sub
Я сам - дурнее всякого примера! ...
 
Забыл. Так еще и удалит строки с исходной. И это - макрорекордером. С доработкой.
Код
Sub www()
    Sheets("History_").Unprotect "123"
    Sheets("History_").UsedRange.ClearContents
    With Sheets("Action-Log").Range("B2").CurrentRegion
        .AutoFilter 10, "Выполнен"
        .Copy Sheets("History_").Range("B2")
        .Offset(1).SpecialCells(12).EntireRow.Delete
        .Parent.AutoFilterMode = 0
    End With
    Sheets("History_").Protect "123"
End Sub 
Я сам - дурнее всякого примера! ...
 
KuklP, идея с автофильтром хороша (не сообразил, честно), но там надо не все колонки переносить и нумерацию обновлять
 
c нумерацией нет проблем, можно не обновлять... но возник другой вопросик, вернее я упустил(результат нехватки времени :sceptic:, простите, приходится писать только когда есть свободная минутка)

возможно ли доработка макроса для добавления перенесенных данных на последнюю свободную строку в листе History_?
Т.е. необходимо видить общий объем перенесенных данных(строк) за все время...

ps-скачал книгу Мэтью Харрис по VBA, буду изучать дома, по выходным... (хотя нет инета и компа дома, хоть буду теорию знать)
 
sbirliko, возможно, но если Вы не удалите заранее уже перенесенные строки из таблицы-источника, они продублируются в таблице-результате. Как вариант, можно удалять уже перенесенную строку из источника. В принципе, можно даже видоизменить, чтобы при внесении Выполнено в колонку Статус, соответствующая строка переносилась в результирующую таблицу и удалялась из исходной. Подумайте, как Вы планируете организовать свои данные и исходя уже из этого можно будет пробовать что-то сделать :)
 
МВТ, Те колонки, что не надо переносить(я не обратил внимания) можно просто скрыть на время переноса.
Я сам - дурнее всякого примера! ...
 
Так, вроде все учел:
Код
Sub www()
    Dim lr
    With Sheets("History_")
        lr = .Cells(65536, 2).End(xlUp).Row + 1
        .Unprotect "123"
        '        .UsedRange.Clear
    End With
    With Sheets("Action-Log").Range("B2").CurrentRegion
        .Columns("H:I").Hidden = -1
        .AutoFilter 10, "Выполнен"
        If lr = 2 Then
            .Copy Sheets("History_").Range("B2")
        Else
            .Offset(1).Copy Sheets("History_").Range("B" & lr)
        End If
        .Columns("H:I").Hidden = 0
        .Offset(1).SpecialCells(12).EntireRow.Delete
        .Parent.AutoFilterMode = 0
    End With
    Sheets("History_").Protect "123"
End Sub
Изменено: KuklP - 07.04.2015 15:09:45
Я сам - дурнее всякого примера! ...
 
KuklP и МВТ большое спасибо за оказанную помощь!  
 
Отличный макрос, огромнейшее спасибо!
 
KuklP, добрый день!
Вы не смогли бы изменить макрос таким образом, чтобы он смог переносить данные на другой лист ПОСТРОЧНО.
В моем документе я выбираю данные на листе 1 и переношу их на лист 2 с учетом даты.
По идее, макрос должен найти пустую строку и вставить туда скопированное значение.
Страницы: 1
Наверх