Vba excel копирование строки с листа на лист

 

paha83

Пользователь

Сообщений: 12
Регистрация: 01.01.1970

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

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

Спасибо!

Прикрепленные файлы

  • Копия.xlsx (48.88 КБ)

 

CAHO

Пользователь

Сообщений: 2183
Регистрация: 25.02.2013

Пункт 3 и 4 противоречат друг другу. Или я не так понял.

Мастерство программиста не в том, чтобы писать программы, работающие без ошибок.
А в том, чтобы писать программы, работающие при любом количестве ошибок.

 

paha83

Пользователь

Сообщений: 12
Регистрация: 01.01.1970

Приветствую, САНО!
Спасибо за внимание.
Может быть я не так описал, попробую разъяснить.
Противоречия невижу, т.к. п. 4 нежен для того чтобы данные с одной даты не задваивались в отчете, если в течении следующего дня после копируемой даты выявится ошибка то необходима возможность внести корректировку и перезаписать данные.
А в случае если пере записывание происходит позже чем 1 день после копируемой даты (п. 5) — это для защиты данных от потери (скажем вредительство).

 

kakaccc

Пользователь

Сообщений: 5
Регистрация: 22.09.2015

#4

22.09.2015 15:38:18

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 пункта.

Прикрепленные файлы

  • Копия — копия.xlsm (54.39 КБ)

Изменено: kakaccc22.09.2015 18:11:32

 

kakaccc

Пользователь

Сообщений: 5
Регистрация: 22.09.2015

#5

23.09.2015 15:35:13

Для 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

Хотя, по-моему, без макроса будет даже проще. Пока он настроен так, что его надо запустить на каждом листе, который будет затем защищен.

Прикрепленные файлы

  • Копия — копия.xlsm (55.93 КБ)

 

paha83

Пользователь

Сообщений: 12
Регистрация: 01.01.1970

Доброго времени суток,

kakaccc!

Большое спасибо за ответ и помощь.
Для меня тема актуальна, т.к. схожие задачи приходится решать постоянно.

Еще раз спасибо!!!

 

rSkrin

Пользователь

Сообщений: 3
Регистрация: 26.02.2016

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

 

kakaccc

Пользователь

Сообщений: 5
Регистрация: 22.09.2015

#8

27.02.2016 17:38:57

Код
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, если сойдет, то потом откалибруем под ваши нужды.

Изменено: kakaccc28.02.2016 02:18:56

 

KuklP

Пользователь

Сообщений: 14868
Регистрация: 21.12.2012

E-mail и реквизиты в профиле.

#9

27.02.2016 18:36:24

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

;)

Я сам — дурнее всякого примера! …

 

TheBestOfTheBest

Пользователь

Сообщений: 2366
Регистрация: 03.04.2015

Excel 2010 +PLEX +SaveToDB +PowerQuery

Файл должен находиться в папке c:1. На таблице ПКМ-Обновить.

Прикрепленные файлы

  • Копия.xlsx (57.41 КБ)

Неизлечимых болезней нет, есть неизлечимые люди.

 

kakaccc

Пользователь

Сообщений: 5
Регистрация: 22.09.2015

KuklP, потому что я нуб в vba  :D

Спасибо! Буду теперь знать и использовать эту функцию.
Но хотел бы сначала разобраться. Объясни, пожалуйста, последнее действие: …copy .Cells(LastRow + 1, 1)
Как это работает? Это типа destination? К чему относится точка перед Cells() Почему, вообще, происходит вставка копируемого?

 

rSkrin

Пользователь

Сообщений: 3
Регистрация: 26.02.2016

Спасибо друзья! Но есть вопрос. Уважаемый kakaccc, правильно ли я понял про «таблица должна начинаться с ячейки А1»- т.е.  начало всей таблицы, в том числе и шапки.  

 

rSkrin

Пользователь

Сообщений: 3
Регистрация: 26.02.2016

Вопрос отменяю. Чуть подправил, проверил работу, все отлично!!! Спасибо.

 

KuklP

Пользователь

Сообщений: 14868
Регистрация: 21.12.2012

E-mail и реквизиты в профиле.

#14

28.02.2016 13:55:14

Цитата
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, причем составлено гораздо профессиональней и понятней чем в моем объяснении.

Я сам — дурнее всякого примера! …

 

kakaccc

Пользователь

Сообщений: 5
Регистрация: 22.09.2015

KuklP, все, раз это destination, то вопросов нет. Более менее разобрался. Буду теперь пользоваться. Красиво и лаконично получилось. Спасибо за объяснение!

rSkrin, да, вся таблица должна начинаться с А1 (шапка в вашемслучае). Можно сделать независимо от находжения таблицы, используя свойство CurrentRegion, например. Но тогда перед запуском макроса надо будет выделять какую-нибудь ячейку из таблицы. Первоначально я так и записал макрос. Не знал как для вас проще будет. Если хотите, можно так сделать.

 

0mega

Пользователь

Сообщений: 170
Регистрация: 24.12.2012

#16

06.11.2022 11:54:18

KuklP

, здравствуйте

Цитата
KuklP написал:
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

почему команда начинается с точки
LastRow = .Cells(.Rows …
Ранее Вы предоставили  «общепринятую «

Цитата
написал:
LastRow = Cells(Rows.Count, 1).End(xlUp).Row

Какое у них отличие ?

 

MikeVol

Пользователь

Сообщений: 229
Регистрация: 20.10.2020

Ученик

#17

06.11.2022 12:29:09

0mega, Думаю если вы прочтёте справку то возможно поймёте что к чему.

почему команда начинается с точки

Вырезание, перемещение, копирование и вставка ячеек (диапазонов) в VBA Excel. Методы Cut, Copy и PasteSpecial объекта Range, метод Paste объекта Worksheet.

Метод Range.Cut

Range.Cut – это метод, который вырезает объект Range (диапазон ячеек) в буфер обмена или перемещает его в указанное место на рабочем листе.

Синтаксис

Параметры

Параметры Описание
Destination Необязательный параметр. Диапазон ячеек рабочего листа, в который будет вставлен (перемещен) вырезанный объект Range (достаточно указать верхнюю левую ячейку диапазона). Если этот параметр опущен, объект вырезается в буфер обмена.

Для вставки на рабочий лист диапазона ячеек, вырезанного в буфер обмена методом Range.Cut, следует использовать метод Worksheet.Paste.

Метод Range.Copy

Range.Copy – это метод, который копирует объект Range (диапазон ячеек) в буфер обмена или в указанное место на рабочем листе.

Синтаксис

Параметры

Параметры Описание
Destination Необязательный параметр. Диапазон ячеек рабочего листа, в который будет вставлен скопированный объект Range (достаточно указать верхнюю левую ячейку диапазона). Если этот параметр опущен, объект копируется в буфер обмена.

Метод Worksheet.Paste

Worksheet.Paste – это метод, который вставляет содержимое буфера обмена на рабочий лист.

Синтаксис

Worksheet.Paste (Destination, Link)

Метод Worksheet.Paste работает как с диапазонами ячеек, вырезанными в буфер обмена методом Range.Cut, так и скопированными в буфер обмена методом Range.Copy.

Параметры

Параметры Описание
Destination Необязательный параметр. Диапазон (ячейка), указывающий место вставки содержимого буфера обмена. Если этот параметр не указан, используется текущий выделенный объект.
Link Необязательный параметр. Булево значение, которое указывает, устанавливать ли ссылку на источник вставленных данных: True – устанавливать, False – не устанавливать (значение по умолчанию).

В выражении с методом Worksheet.Paste можно указать только один из параметров: или Destination, или Link.

Для вставки из буфера обмена отдельных компонентов скопированных ячеек (значения, форматы, примечания и т.д.), а также для проведения транспонирования и вычислений, используйте метод Range.PasteSpecial (специальная вставка).

Примеры

Вырезание и вставка диапазона одной строкой (перемещение):

Range(«A1:C3»).Cut Range(«E1»)

Вырезание ячеек в буфер обмена и вставка методом ActiveSheet.Paste:

Range(«A1:C3»).Cut

ActiveSheet.Paste Range(«E1»)

Копирование и вставка диапазона одной строкой:

Range(«A18:C20»).Copy Range(«E18»)

Копирование ячеек в буфер обмена и вставка методом ActiveSheet.Paste:

Range(«A18:C20»).Copy

ActiveSheet.Paste Range(«E18»)

Копирование одной ячейки и вставка ее данных во все ячейки заданного диапазона:

Range(«A1»).Copy Range(«B1:D10»)


In this Article

  • Rows & Columns – Paste vs. Insert
    • Copy & Paste Over Existing Row / Column
    • Copy & Insert Row / Column
  • Copy Entire Row
    • Cut and Paste Rows
    • Copy Multiple Rows
  • Copy Entire Column
    • Cut and Paste Columns
    • Copy Multiple Columns
  • Copy Rows or Columns to Another Sheet
    • Cut Rows or Columns to Another Sheet

This tutorial will teach you how to copy (or cut) entire Rows or Columns using VBA. We cover copying and pasting ranges of cells in another article.

First we will show you how to paste or insert copied rows/columns and discuss the differences.  Then we will show you all of the different ways to references rows and columns when copying or cutting.

Rows & Columns – Paste vs. Insert

When pasting rows and columns you have two options:  You can paste over the existing row (or column) or you can insert a new row (or column).

Let’s look at the difference…

vba copy and paste row

Copy & Paste Over Existing Row / Column

This will copy row 1 and paste it into the existing row 5:

Range("1:1").Copy Range("5:5")

This will copy column C and paste it into column E:

Range("C:C").Copy Range("E:E")

Copy & Insert Row / Column

Instead you can insert the copied row or column and shift the existing rows or columns to make room.

This will copy row 1 and insert it into row 5, shifting the existing rows down:

Range("1:1").Copy
Range("5:5").Insert

This will copy column C and insert it into column E, shifting the existing columns to the right:

Range("C:C").Copy
Range("E:E").Insert

Copy Entire Row

Below we will show you several ways to copy row 1 and paste into row 5.

Range("1:1").Copy Range("5:5")
Range("A1").EntireRow.Copy Range("A5")
Rows(1).Copy Rows(5)

Cut and Paste Rows

Simply use Cut instead of Copy to cut and paste rows:

Rows(1).Cut Rows(5)

Copy Multiple Rows

Here are examples of copying multiple rows at once:

Range("5:7").Copy Range("10:13")
Range("A5:A7").EntireRow.Copy Range("A10:A13")
Rows("5:7").Copy Rows("10:13")

VBA Coding Made Easy

Stop searching for VBA code online. Learn more about AutoMacro — A VBA Code Builder that allows beginners to code procedures from scratch with minimal coding knowledge and with many time-saving features for all users!

automacro

Learn More

Copy Entire Column

You can copy entire columns similarily to copying entire rows:

Range("C:C").Copy Range("E:E")
Range("C1").EntireColumn.Copy Range("C1").EntireColumn
Columns(3).Copy Range(5)

Cut and Paste Columns

Simply use Cut instead of Copy to cut and paste columns:

Range("C:C").Cut Range("E:E")

Copy Multiple Columns

Here are examples of copying multiple columns at once:

Range("C:E").Copy Range("G:I")
Range("C1:E1").EntireColumn.Copy Range("G1:I1")
Columns("3:5").Copy Columns("7:9")

VBA Programming | Code Generator does work for you!

Copy Rows or Columns to Another Sheet

To copy to another sheet, simply use the Sheet Object:

Sheets("sheet1").Range("C:E").Copy Sheets("sheet2").Range("G:I")

Cut Rows or Columns to Another Sheet

You can use the exact same technique to cut and paste rows or columns to another sheet.

Sheets("sheet1").Range("C:E").Cut Sheets("sheet2").Range("G:I")

wishcom

1 / 1 / 0

Регистрация: 17.02.2010

Сообщений: 131

1

18.12.2010, 21:39. Показов 18991. Ответов 20

Метки нет (Все метки)


Студворк — интернет-сервис помощи студентам

Не понимаю почему работат.

Visual Basic
1
2
Worksheets('Work').Range(Cells(2, 1), Cells(2, 14)).Copy
Worksheets('Work').Range(Cells(31, 1), Cells(31, 14)).PasteSpecial

Visual Basic
1
2
Worksheets('Base').Range(Cells(2, 1), Cells(2, 14)).Copy
Worksheets('Work').Range(Cells(31, 1), Cells(31, 14)).PasteSpecial

нет.
Всё прописано в work(List1).
Base(List1).- Другой лист.
Короче. Надо скопировать ряд из одного листа в другой.



0



pashulka

4131 / 2235 / 940

Регистрация: 01.12.2010

Сообщений: 4,624

19.12.2010, 03:06

2

Вы забыли инструкцию Select или Activate

Visual Basic
1
2
3
4
Worksheets('Base').Range(Cells(2, 1), Cells(2, 14)).Copy
Worksheets('Work').Activate ' вариант I
Worksheets('Work').Select   ' вариант II
Worksheets('Work').Range(Cells(31, 1), Cells(31, 14)).PasteSpecial



0



wishcom

1 / 1 / 0

Регистрация: 17.02.2010

Сообщений: 131

19.12.2010, 18:09

 [ТС]

3

Activate Точно отпадает.
Прикинь! Один запрос на 500 записей.
500 раз визуально прыгнуть из одного окна в другое.
А Select не работает.
Мне надо прописать в work(list1)
А прыгать в Base(list2)

Visual Basic
1
2
3
4
5
6
Private Sub CommandButton3_Click()
Worksheets('Base').Select
Worksheets('Base').Range(Cells(2, 1), Cells(2, 14)).Copy
Worksheets('Work').Select
Worksheets('Work').Range(Cells(31, 1), Cells(31, 14)).PasteSpecial
End Sub



0



4131 / 2235 / 940

Регистрация: 01.12.2010

Сообщений: 4,624

19.12.2010, 18:36

4

Вы спросили, почему не работает Ваш код, и я ответил, что
Paste нужно применять только в активном листе, поэтому я и предложил инструкцию Select, Activate (что в данном случае одно и тоже)
—————————————-



0



1 / 1 / 0

Регистрация: 17.02.2010

Сообщений: 131

19.12.2010, 20:48

 [ТС]

5

Неужели никак иначе.
Exel когда переносит, то всякая хрень перел глазами не маячит.



0



4131 / 2235 / 940

Регистрация: 01.12.2010

Сообщений: 4,624

19.12.2010, 21:39

6

Можно и иначе, советую более внимательно ознакомиться с help.
Вот самый примитивный пример :
Worksheets(‘Work’).Cells(1) = Worksheets(‘Base’).Cells(1)
будет работать независимо от того в каком листе этой рабочей книги Вы находитесь.



0



22 / 5 / 1

Регистрация: 05.09.2010

Сообщений: 370

20.12.2010, 09:55

7

Так чтобы не маячило, может надо
Application.ScreenUpdating = False
в начале поставить?



0



1 / 1 / 0

Регистрация: 17.02.2010

Сообщений: 131

20.12.2010, 20:04

 [ТС]

8

Да отлично я это знаю.
Мне для Range надо!!!!!
Worksheets(‘Work’).Range(Cells(2, 1), Cells(2, 2)) = Worksheets(‘Base’).Range(Cells(2, 1), Cells(2, 2))
Не работает!



0



22 / 5 / 1

Регистрация: 05.09.2010

Сообщений: 370

21.12.2010, 05:25

9

А так?
Range(Worksheets(‘Work’).Cells(2, 1), Worksheets(‘Work’).Cells(2, 2)).Value = Range(Worksheets(‘Base’).Cells(2, 1), Worksheets(‘Base’).Cells(2, 2)).Value



0



1 / 1 / 0

Регистрация: 17.02.2010

Сообщений: 131

21.12.2010, 22:56

 [ТС]

10

НЕ…
я это естественно пробывал.



0



4131 / 2235 / 940

Регистрация: 01.12.2010

Сообщений: 4,624

22.12.2010, 07:06

11

А вот так …
iLists = Array(‘Base’, ‘Work’)
Worksheets(iLists).FillAcrossSheets Worksheets(‘Base’).Range(‘A2:B2’)



0



wishcom

1 / 1 / 0

Регистрация: 17.02.2010

Сообщений: 131

22.12.2010, 20:06

 [ТС]

12

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Private Sub cmdProv_Click()
'Dim iLists
'iLists = Array('Base', 'Work')
'Мне во что надо. В цикле!!!
'Worksheets(iLists).FillAcrossSheets Worksheets('Base').Range(Cells(i, n), Cells(i+15, n)).Value
'Не работает!
 
'Я тут прикинул. Если функцию найти не можем,то надо написать самому.
Dim iLists
iLists = Array('Base', 'Work')
'm = 'A7: IV7' Копируем всю седьмую полосу!
Call mat(0, 7, 256, 7, iLists, 'Base')
'Это конечно бред. Но он работает. Может пригодиться кому-либо.
'Можете продолжать копать дальше. Найдёте скиньте!!! Please! Хватит извращений.
End Sub
Private Sub mat(num_1 As Integer, num_2 As Long, num_3 As Integer, _
num_4 As Long, listNom, ListName As String) 'wishco@yandex.ru 14.10.2004
If num_1 > 256 Or num_3 > 256 Then MsgBox 'Out of range': Exit Sub
Dim m As String: Dim m2 As String: Dim m3 As String
Dim n_1 As Integer: Dim num0 As Integer
num0 = num_1
met:
For n_1 = 0 To 8
    If num0 > 25 Then
    num0 = num0 - 26
    Else: If n_1 <> 0 Then n_1 = n_1 - 1
    Exit For: End If
Next n_1
If n_1 <> 0 Then: m = Chr(n_1 + 64)
 If num0 <> 0 Then
 m = m & Chr(num0 + 64)
 Else: m = m & Chr(65): End If
If m2 = '' Then m2 = m: m = '': num0 = num_3: GoTo met
m3 = m2 & num_2 & ':' & m & num_4
Worksheets(listNom).FillAcrossSheets Worksheets(ListName).Range(m3)
End Sub



0



pashulka

4131 / 2235 / 940

Регистрация: 01.12.2010

Сообщений: 4,624

22.12.2010, 22:58

13

А вот так :

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub ExtremePerverts()
 
iRow = 2: iCol = 2
 
iColTemp = iNameColumn(iRow, iCol)
iDiapazon = iColTemp & iRow & ':' & iColTemp & iRow + 2
 
iLists = Array('Base', 'Work')
Worksheets(iLists).FillAcrossSheets Worksheets('Base').Range(iDiapazon)
 
End Sub
 
Function iNameColumn(iRow, iCol)
 
iAddress = Cells(iRow, iCol).Column
 
iAdr = Cells(iRow, iCol).Address(RowAbsolute:=False, ColumnAbsolute:=False)
 
If iAddress > 26 Then
   iNameColumn = Left(iAdr, 2)
Else
   iNameColumn = Left(iAdr, 1)
End If
 
End Function

‘хотя в Excel наверняка существует функция возвращающая имя столбца,
‘если известен его номер (Count)



0



1 / 1 / 0

Регистрация: 17.02.2010

Сообщений: 131

23.12.2010, 18:14

 [ТС]

14

У тебя код побыстрее, но у меня для Rows и Cols, в функции содержатся все операторы.
Сделай также, и проставь переменные. И я возьму твой код.
Скажу заранее спасибо.

Кстати. Ссылка на адрес… это черевато крахом Exel.
У меня пару раз вылетал в исправлении кода. Давай дорабатывай.



0



4131 / 2235 / 940

Регистрация: 01.12.2010

Сообщений: 4,624

24.12.2010, 01:41

15

Этот код я написал специально для Вас, и в свете вышеописанных задач он свою функцию выполняет на 100%.
P.S. Что касается моей функции, то я в ней Const не увидел.
А проблему с Office можно свести к минимуму если поставить не ставить ломаные версии.



0



1 / 1 / 0

Регистрация: 17.02.2010

Сообщений: 131

24.12.2010, 11:29

 [ТС]

16

У меня сверху стоит Option Explicit
и если необъявлять не все переменные, то и происходит ошибка.
А в сумме с запросом к адресу, то вылетает ошибка типа GPF.

Ну мне покрайней мере надо было
iAddress = Cells(iRow, iCol).rows

Не. Дописал бы.. Самому пригодилось бы…



0



wishcom

1 / 1 / 0

Регистрация: 17.02.2010

Сообщений: 131

24.12.2010, 14:01

 [ТС]

17

Я тут к твоему коду присмотрелся и написал…

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Private Sub CommandButton2_Click()
Call iCopyRows(5, 2, 1, 14, 'Base', 'work')
'5-номер копируемого ряда из Base,2-номер вставляемого ряда в work
'1-14 Размер ряда.
End Sub
 
Sub iCopyRows(iRow, i2Row, iCol, i2Col, listCopy, ListPaste)
Dim iAdr1 As String, iAdr2 As String, iAdr3 As String, iAdr4 As String
iAdr1 = Cells(iRow, iCol).Address(RowAbsolute:=False, ColumnAbsolute:=False)
iAdr2 = Cells(iRow, i2Col).Address(RowAbsolute:=False, ColumnAbsolute:=False)
iAdr3 = Cells(i2Row, iCol).Address(RowAbsolute:=False, ColumnAbsolute:=False)
iAdr4 = Cells(i2Row, i2Col).Address(RowAbsolute:=False, ColumnAbsolute:=False)
Worksheets(listCopy).Range(iAdr1 & ':' & iAdr2).Copy
Worksheets(ListPaste).Range(iAdr3 & ':' & iAdr4).PasteSpecial
End Sub



0



Dimakart

0 / 0 / 1

Регистрация: 11.10.2010

Сообщений: 48

24.12.2010, 19:51

18

А вот так не проще ли будет ?

Visual Basic
1
2
3
4
5
Dim i As Integer
 For i = 1 To 14
  Worksheets('Work').Cells(31, i) = Worksheets('Base').Cells(2, i).Value
 Next
End Sub



0



1 / 1 / 0

Регистрация: 17.02.2010

Сообщений: 131

24.12.2010, 22:08

 [ТС]

19

По моему мой код побыстрее…
Как узнать что нет?



0



4131 / 2235 / 940

Регистрация: 01.12.2010

Сообщений: 4,624

25.12.2010, 01:21

20

Снимаю шляпу перед Dimakart. Я этот код хотел оставить напоследок, как мега извращение. Теперь снова придётся придумывать что-то более извращённое.
Проверить быстроту работы кода, можно :
1) включив в программу таймер
2) засечь время в начале и в конце работы программы, а разница между ними собственно говоря и есть время работы программы.
P.S. Но вариант с таймером проще.



0



I have two sheets containing the employee records.
Sheet1 contains the Event Date, CardNo, Employee Name, Dept Id, Employee No, Entry and Exit Time, Total Working Hours, Status, ConcatinatedColumn and Remarks (copied through vlookup from sheet2)

Sheet2 contains ConcatinatedColumn, Event Date, Employee No, Name, Remarks.

If the data in the remarks column of sheet2 is «Sick Off» then that row should be inserted to sheet1 without effecting the previous records.

I’ve already written the code for it but it does not work.

Would be really grateful if anyone can help me out !

THANKS IN ADVANCE !

MY CODE :

Sub SickOff()

Dim objWorksheet As Sheet2
Dim rngBurnDown As Range
Dim rngCell As Range
Dim strPasteToSheet As String

'Used for the new worksheet we are pasting into
Dim objNewSheet As Sheet1

Dim rngNextAvailbleRow As Range

'Define the worksheet with our data
Set objWorksheet = ThisWorkbook.Worksheets("Sheet2")


'Dynamically define the range to the last cell.
'This doesn't include and error handling e.g. null cells
'If we are not starting in A1, then change as appropriate
Set rngBurnDown = objWorksheet.Range("G2:G" & objWorksheet.Cells(Rows.Count,       "G").End(xlUp).Row)

'Now loop through all the cells in the range
For Each rngCell In rngBurnDown.Cells

objWorksheet.Select

If rngCell.Value = "Sick Off" Then
'select the entire row
rngCell.EntireRow.Select

'copy the selection
Selection.Copy

'Now identify and select the new sheet to paste into
Set objNewSheet = ThisWorkbook.Worksheets("Sheet1" & rngCell.Value)
objNewSheet.Select

'Looking at your initial question, I believe you are trying to find the next     available row
Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)


Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
End If

Next rngCell

objWorksheet.Select
objWorksheet.Cells(1, 1).Select

'Can do some basic error handing here

'kill all objects
If IsObject(objWorksheet) Then Set objWorksheet = Nothing
If IsObject(rngBurnDown) Then Set rngBurnDown = Nothing
If IsObject(rngCell) Then Set rngCell = Nothing
If IsObject(objNewSheet) Then Set objNewSheet = Nothing
If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing

End Sub

Понравилась статья? Поделить с друзьями:
  • Vba excel копирование строк по условию
  • Vba excel копирование строк на другой лист
  • Vba excel копирование папки
  • Vba excel копирование несвязанных диапазонов
  • Vba excel копирование на один лист