|
|
Регистрация Восстановить пароль |
Повторная активизация e-mail |
Регистрация | Задать вопрос |
Заплачу за решение |
Новые сообщения |
Сообщения за день |
Расширенный поиск |
Правила |
Всё прочитано |
|
Опции темы | Поиск в этой теме |
11.07.2012, 17:53 | #1 |
Новичок
Джуниор
Регистрация: 11.07.2012
Сообщений: 1
|
Макрос по копированию
День добрый
Не получилось переделать макрос для следующего задания: Нужно таблицу состоящей из 4-х столбцов из файла №1 - первый наименование, 3 других числовые, сравнить с другим файлом №2, и в случае совпадения наименования и 2 других столбцов скопировать в файл №2 содержимое 3-го столбца с цифрами. Никто не может подсказать, в чем тут ошибка? Option Explicit Sub Test1() Const DataRange = "A:E" Dim Arr1(), Arr2(), Arr3(), Arr4(), r&, c&, rs&, ds&, cs&, rs1&, ds1&, cs1&, i&, r1&, c1& Test2 Arr1() = Intersect(ActiveSheet.UsedRange, Range(DataRange)).Value rs = UBound(Arr1, 3) cs = UBound(Arr1, 4) ds = UBound(Arr1, 5) ReDim Arr2(1 To rs, 1 To 1) Windows("ëèñò2").Activate rs1 = UBound(Arr3, 3) cs1 = UBound(Arr3, 4) ds1 = UBound(Arr1, 5) ReDim Arr4(1 To rs, 1 To 1) Windows("ëèñò1").Activate For c = 1 To cs Step 3 For r = 1 To rs If Arr1(r, c + 2) = Cells(r1, c1 + 2) Then If Arr1(r, c + 3) = Cells(r1, c1 + 3) Then If Arr1(r, c + 4) = Cells(r1, c1 + 4) Then i = i + 1 Arr2(i, 1) = Arr1(r, c + 2) End If End If End If Next Next ReDim Arr1(0) If i > 0 Then If i > Rows.Count Then MsgBox "Íàéäåíî: " & i, 16, "!": Exit Sub On Error Resume Next Application.DisplayAlerts = False Application.ScreenUpdating = False Sheets("Result").Delete With Sheets.Add .Name = "Result" Range("F1").Resize(i).Value = Arr2() End With Application.DisplayAlerts = True Application.ScreenUpdating = True End If End Sub Sub Test2() With ActiveSheet.UsedRange .FormatConditions.Delete .FormatConditions.Add Type:=xlExpression, Formula1:="=(RC[-1]=6)*(RC[-2]=6)" .FormatConditions(1).Interior.Color Index = 40 End With End Sub |
Опции темы | Поиск в этой теме |
Похожие темы | ||||
Тема | Автор | Раздел | Ответов | Последнее сообщение |
Задание по копированию строк, strncpy | McToNy | Помощь студентам | 0 | 03.06.2012 16:45 |
доработка макроса по копированию данных | Nick31 | Microsoft Office Excel | 1 | 16.05.2012 10:31 |
Макрос по копированию строки, в зависимости от даты | Feller | Microsoft Office Excel | 2 | 02.11.2011 19:30 |
Вопрос по копированию файлов | Arsti | Помощь студентам | 2 | 29.01.2010 11:12 |
Макрос по копированию данных из другого фаила | Devourer12345 | Microsoft Office Excel | 30 | 17.07.2008 04:54 |