Страницы: 1 2 3 След.
RSS
Копирование строк с одного листа на другой VBA.
 
Доброго времени суток уважаемые форумчане!
Имею задачу которую не могу решить сам, из-за отсутствия знаний и навыков.
Исходные данные:
1. Несколько одинаковых по структуре листов (см. пример) 1, 2, 3;
2. Лист "Финиш".

Задача. С помощью VBA:
1. Скопировать строки из активнного листа либо1, либо 2... и вставить их на лист "Финиш".
Условия:
1. Копировать строки только при условии заполненной ячейки в столбце  "В";
2. Скопированные строки должбыть вставлены как значения;
3. При копировании новых данных на лист "Финиш" они должны вставляться ниже старых;
4. Если в листе "Финиш" есть заполненные строки с копируемой датой, то старые затираются, а на их место становятся новые;
5. Перезаписать данные можно только в течении 1-го дня после указанной даты в листах 1, 2 ..., либо при вводе пароля (скажем 143).

Спасибо!
 
Пункт 3 и 4 противоречат друг другу. Или я не так понял.
Мастерство программиста не в том, чтобы писать программы, работающие без ошибок.
А в том, чтобы писать программы, работающие при любом количестве ошибок.
 
Приветствую, САНО!
Спасибо за внимание.
Может быть я не так описал, попробую разъяснить.
Противоречия невижу, т.к. п. 4 нежен для того чтобы данные с одной даты не задваивались в отчете, если в течении следующего дня после копируемой даты выявится ошибка то необходима возможность внести корректировку и перезаписать данные.
А в случае если пере записывание происходит позже чем 1 день после копируемой даты (п. 5) - это для защиты данных от потери (скажем вредительство).
 
paha83, если еще актуально:
Код
Sub Copy_rows_if()
Dim currentRow As Integer
Dim sourceCol As Integer
Dim LastRow As Integer
Dim currentRowValue
Dim sourcews As String

sourcews = ActiveSheet.Name 'базовый лист
sourceCol = 2   'колонка B ключевая
RowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row

For currentRow = 1 To RowCount  'для всех строк базового листа
    currentRowValue = Cells(currentRow, sourceCol).Value
    If Not (IsEmpty(currentRowValue) Or currentRowValue = "") Then
          Rows(currentRow).Copy
          Worksheets("Финиш").Select
          LastRow = Cells(Rows.Count, sourceCol).End(xlUp).Row
          Range(Cells(LastRow + 1, 1), Cells(LastRow + 1, 1)).PasteSpecial Paste:=xlPasteValues
          Worksheets(sourcews).Activate
    End If
Next
End Sub

Здесь первые 3 пункта.
Изменено: kakaccc - 22.09.2015 18:11:32
 
Для 5 пункта:
Код
Sub zashita_dannyh()
Dim currentRow As Integer
Dim sourceCol As Integer
Dim data As String

sourceCol = 2
RowCount = Cells(1, sourceCol).End(xlDown).Row
RowCount_2 = ActiveSheet.Cells(RowCount, sourceCol).End(xlDown).Row
data = Range(Cells(RowCount, sourceCol), Cells(RowCount, sourceCol)).Value

'проверка на ошибку
For currentRow = RowCount To RowCount_2 - 2
    currentRowValue = Cells(currentRow, sourceCol).Value
    If Not (IsEmpty(currentRowValue) Or currentRowValue = "") And _
    Cells(currentRow + 1, sourceCol).Value <> currentRowValue Then
        MsgBox ("даты на лите не совпадают")
        Exit Sub
    End If
Next

'протектим лист
If Date - DateValue(data) > 1 Then
ActiveSheet.Protect Password:="143" 'пароль 143
End If
End Sub
Хотя, по-моему, без макроса будет даже проще. Пока он настроен так, что его надо запустить на каждом листе, который будет затем защищен.
 
Доброго времени суток, kakaccc!
Большое спасибо за ответ и помощь.
Для меня тема актуальна, т.к. схожие задачи приходится решать постоянно.

Еще раз спасибо!!!
 
Добрый день!
Друзья, знатоки Excel, подскажите пожалуйста решение проблемы, аналогичной вышеизложенной с небольшим усложнением. Требуется скопировать все строки таблицы ежедневного отчета, кроме шапки (т.е. начиная с 5-й строки), из листа "отчет" в лист "архив", ниже ранее скопированных, при условии заполнения  всех ячеек в столбце 5 (Е), т.е . достигнута полнота отчета. Если хоть одна ячейка в столбце 5 не заполнена не производить копирование на лист  "архив". И подскажите пожалуйста, возможно ли отображение строк на листе "архив", с рамками как в таблице на листе "отчет" или автоматическое добавление границ таблицы.
 
Код
Sub copy_to_archive()

Dim currentRow As Integer
Dim sourceCol As Integer
Dim LastRow As Integer
Dim currentRowValue
Dim sourcews As String
Dim Rowsnum As Integer

sourcews = ActiveSheet.Name 'базовый лист
sourceCol = 5   'Ключевая E колонка
Set myTable = Worksheets(sourcews).Range("A1").CurrentRegion
Rowsnum = myTable.Rows.Count

For currentRow = 5 To Rowsnum  'проверяем есть ли пустые в 5-ой колонке
    currentRowValue = Cells(currentRow, sourceCol).Value
    If (IsEmpty(currentRowValue) Or currentRowValue = "") Then
    MsgBox ("Внимание! Есть пустые ячейки.")
    Exit Sub
    End If
Next

For currentRow = 5 To Rowsnum  'Копируем
    Rows(currentRow).Copy
    Worksheets("Архив").Select
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    With Range(Cells(LastRow + 1, 1), Cells(LastRow + 1, 1))
    .PasteSpecial Paste:=xlPasteValues
    .PasteSpecial Paste:=xlPasteFormats
    End With
    Worksheets(sourcews).Activate
Next
End Sub
Немного громоздкий макрос получился.
Ограничение такое: таблица должны начинаться с ячейки А1.
rSkrin, если сойдет, то потом откалибруем под ваши нужды.
Изменено: kakaccc - 28.02.2016 02:18:56
 
kakaccc, чем по-Вашему будут отличаться результаты, если блок:
Код
For currentRow = 5 To Rowsnum 'Копируем
 Rows(currentRow).Copy
 Worksheets("Архив").Select
 LastRow = Cells(Rows.Count, 1).End(xlUp).Row
 With Range(Cells(LastRow + 1, 1), Cells(LastRow + 1, 1))
 .PasteSpecial Paste:=xlPasteValues
 .PasteSpecial Paste:=xlPasteFormats
 End With
 Worksheets(sourcews).Activate
Next

записать так:
Код
with Worksheets("Архив")
     LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
     myTable.offset(5).resize(myTable.Rows.Count-5).copy .Cells(LastRow + 1, 1)
end with
;)
Я сам - дурнее всякого примера! ...
 
Файл должен находиться в папке c:\1\. На таблице ПКМ-Обновить.
Неизлечимых болезней нет, есть неизлечимые люди.
 
KuklP, потому что я нуб в vba  :D

Спасибо! Буду теперь знать и использовать эту функцию.
Но хотел бы сначала разобраться. Объясни, пожалуйста, последнее действие: ...copy .Cells(LastRow + 1, 1)
Как это работает? Это типа destination? К чему относится точка перед Cells() Почему, вообще, происходит вставка копируемого?
 
Спасибо друзья! Но есть вопрос. Уважаемый kakaccc, правильно ли я понял про "таблица должна начинаться с ячейки А1"- т.е.  начало всей таблицы, в том числе и шапки.  
 
Вопрос отменяю. Чуть подправил, проверил работу, все отлично!!! Спасибо.
 
Цитата
kakaccc написал:
Это типа destination? К чему относится точка перед Cells()
Да, это destination.
выражением with Worksheets("Архив") мы объявляем ссылку  на родительский объект Worksheets("Архив"). дальше всему, что начинается с точки, вба будет пытаться присвоить родительский объект. Т.е. конструкцию
Код
with Worksheets("Архив")
 LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
 myTable.offset(5).resize(myTable.Rows.Count-5).copy .Cells(LastRow + 1, 1)
end with

можно записать буквально:
Код
 LastRow = Worksheets("Архив").Cells(Worksheets("Архив").Rows.Count, 1).End(xlUp).Row
 myTable.offset(5).resize(myTable.Rows.Count-5).copy Worksheets("Архив").Cells(LastRow + 1, 1)
в этом слуячае родительский объект вычисляется 3 раза вместо одного в предыдущем примере.
ВСЕ ЭТО и много другого интересного есть в справке по F1, причем составлено гораздо профессиональней и понятней чем в моем объяснении.
Я сам - дурнее всякого примера! ...
 
KuklP, все, раз это destination, то вопросов нет. Более менее разобрался. Буду теперь пользоваться. Красиво и лаконично получилось. Спасибо за объяснение!

rSkrin, да, вся таблица должна начинаться с А1 (шапка в вашемслучае). Можно сделать независимо от находжения таблицы, используя свойство CurrentRegion, например. Но тогда перед запуском макроса надо будет выделять какую-нибудь ячейку из таблицы. Первоначально я так и записал макрос. Не знал как для вас проще будет. Если хотите, можно так сделать.
 
KuklP, здравствуйте
Цитата
KuklP написал:
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
почему команда начинается с точки
LastRow = .Cells(.Rows ...
Ранее Вы предоставили  "общепринятую "
Цитата
написал:
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Какое у них отличие ?
 
0mega, Думаю если вы прочтёте справку то возможно поймёте что к чему.
почему команда начинается с точки
 
Подскажите пожалуйста, как из массива данных первого листа, выдернуть данные по условию "истина" на второй лист в ячейку с3 и вставить через запятую
Тоже необходимо вставить как текст или значения без исходного форматирования, при копировании новых данных должны вставляться ниже старых
Изменено: БМВ - 03.03.2024 10:28:35
 
Например так:

Sub Perenos()

Dim MyValues As Variant

'задаем массив
MyValues = Worksheets("данные").Range("A1:B8")

'перебираем данные
For i = 1 To UBound(MyValues, 1)

If MyValues(i, 1) = True Then
   'если еще ни одно не перенесено
   If IsEmpty(Worksheets("вывод").Range("C3").Value) Then
       Worksheets("вывод").Range("C3") = MyValues(i, 2)
   'если уже был перенос значений
   Else
       Worksheets("вывод").Range("C3") = Worksheets("вывод").Range("C3").Value _
       & Chr(44) & Chr(32) & MyValues(i, 2)
   End If
End If

Next i

End Sub
Изменено: kakaccc - 03.03.2024 22:06:45
 
Еще уточню, нужно чтоб данные на первом листе остались)
 
Может лучше тогда добавить все те же данные с уловием истина, я вставил код, но он добавляет только 1 первое найденное значение и все
Sub CopyInfo()
'объявление переменных
Dim iLastRowNal As Long
Dim iLastRowArhiv As Long

Sheets("Список").Select
'проверка наличия данных (заполнености) последнего столбца таблицы
   iLastRowNal = Cells(Rows.Count, 2).End(xlUp).Row 'вычисление номера строки
   
       
   
   For i = 3 To iLastRowNal
       If Cells(i, 1) = "True" Then
           'определение последней заполненой строки на листе Архив
           iLastRowArhiv = Sheets("Табель").Cells(Rows.Count, 7).End(xlUp).Row + 1
           
           Range(Cells(i, 2), Cells(i, 2)).Copy
           Sheets("Табель").Select
   LastRow = Cells(Rows.Count, "G").End(xlUp).Row + 1
   Cells(LastRow, 7).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
           
       End If
   Next i
   
End Sub
 
как в моем случае увеличить переменную-счётчик
 
В приведенном мною коде данные на первом листе остаются без изменений. Чем вам не вариант?

Если настаиваете на своем коде, то добавьте строку: Sheets("Список").Select сразу после For i = 3 To iLastRowNal, тогда будет работать. Но вы просили в одну ячейку и через запятую, а в вашем коде данные добавляются друг под другом и без запятых.
Изменено: kakaccc - 03.03.2024 16:55:58
 
Спасибо Ваш код отлично работает, но постоянно данные записываются с3 т.е обновляются, возможно ли доработать чтоб при повторном вызове кода новые данные отобразились с4 и т.д. Т.е постоянно при вызове кода данные вставлялись бы ниже старых

елка, мороз, сани
ветер, пурга, буря
рыбалка, дом, качеля, солнце
 
Baidut, пардон, забыл добавить это условие. Тогда так:

Sub Perenos()

Dim MyValues As Variant
Dim iLastRowNal As Long
Dim MyRange As Range

'задаем массив
MyValues = Worksheets("данные").Range("A1").CurrentRegion 'или конкретно Range("A1:B8")

'вычисление последней строки в нужном столбце (здесь 3ий)
LastRowNal = Cells(Rows.Count, 3).End(xlUp).Row

Worksheets("вывод").Select

'задаем ячейку для вывода значений
Set MyRange = Worksheets("вывод").Range(Cells(LastRowNal + 1, 3), Cells(LastRowNal + 1, 3))

'перебираем данные
For i = 1 To UBound(MyValues, 1)

If MyValues(i, 1) = True Then
  'если еще ни одно не перенесено
  If IsEmpty(MyRange) Then
       MyRange = MyValues(i, 2)
  'если уже был перенос значений
  Else
       MyRange = MyRange & Chr(44) & Chr(32) & MyValues(i, 2) 'добавляем через запятую
  End If
End If

Next i

End Sub
Изменено: kakaccc - 03.03.2024 22:07:14
 
Спасибо. можешь подсказать код чтобы выборка была по горизонтали, точь-точь условия как я код делал только по вертикали нужно
 
Да. Тогда так:

Sub Perenos()

Dim MyValues As Variant
Dim iLastRowNal As Long
Dim MyRange As Range

'задаем массив
MyValues = Worksheets("вывод").Range("D3").CurrentRegion

'вычисление последней строки в нужном столбце
LastRowNal = Cells(Rows.Count, 3).End(xlUp).Row

Worksheets("вывод").Select

'задаем ячейку для вывода значений
Set MyRange = Worksheets("вывод").Range(Cells(LastRowNal + 1, 3), Cells(LastRowNal + 1, 3))

'перебираем данные
For i = 1 To UBound(MyValues, 2)

If MyValues(1, i) = True Then
 'если еще ни одно не перенесено
 If IsEmpty(MyRange) Then
      MyRange = MyValues(2, i)
 'если уже был перенос значений
 Else
      MyRange = MyRange & Chr(44) & Chr(32) & MyValues(2, i) 'добавляем через запятую
 End If
End If

Next i

End Sub
Изменено: kakaccc - 03.03.2024 22:07:29
 
Спасибо
 
Sub CopyInfo()
'объявление переменных
Dim iLastRowNal As Long
Dim iLastRowArhiv As Long

Sheets("Список").Select
'проверка наличия данных (заполнености) последнего столбца таблицы
  iLastRowNal = Cells(Rows.Count, 2).End(xlUp).Row 'вычисление номера строки
 
     
 
  For i = 3 To iLastRowNal
Sheets("Список").Select
      If Cells(i, 1) = "True" Then
          'определение последней заполненой строки на листе Архив
          iLastRowArhiv = Sheets("Табель").Cells(Rows.Count, 7).End(xlUp).Row + 1
         
          Range(Cells(i, 2), Cells(i, 2)).Copy
          Sheets("Табель").Select
  LastRow = Cells(Rows.Count, "G").End(xlUp).Row + 1
  Cells(LastRow, 7).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
         
      End If
  Next i
 
End Sub


добавил к своему коду, все равно только 1 значение вводит
 
может у меня код карявый. как все таки сделать чтобы данные добавлялись друг под другом и без запятых
Страницы: 1 2 3 След.
Читают тему
Наверх