ReSQL.ru
     
powered by simpleCommunicator - 2.0.61     © 2026 Programmizd 02
Мобильная версия    Контакт    Правила    FAQ    Помощь
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Доб. в избранное | Игнор. тему | Прикреп. тему | Пометить прочит. / непрочит. | Фильтр
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Нужна помощь
10 сообщений из 10, страница 1 из 1
Нужна помощь
    #34040470
Лев
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Лев
Гость
Помогите написать макрос к EXCEL.
Файл EXCEL состоит из 4-х страниц
На Стр.1, Стр.2, Стр.3 имеются следующие таблицы

Наименование столбцов:
Код (число)
Наименование объекта
1 (число месяца)
2
…
31

Число объектов на каждой странице (до 200)
Код имеет вид 5-ти значного числа, индивидуален для каждого объекта, последовательность кодов на каждой странице произвольная, но отсортирована по возрастанию.

На Стр.4 имеется таблица, которая заполняется ежедневно
Наименование столбцов:
Код
Наименование объекта
Информация
Код
Наименование объекта
Информация
Код
Наименование объекта
Информация

При этом 3 первых столбца таблицы относятся к объектам Стр.1
4, 5, 6 столбцы к объектам Стр.2
7, 8, 9 столбцы к объектам Стр.3
Число объектов в каждой из трех частей таблицы (до 20) и оно меняется или повторяется, так же как и сами объекты произвольно каждый день.
Данные из ячеек столбца "Информация" Стр.4 необходимо сохранить в ячейках пересечения строки, соответствующей объекту, и столбца, соответствующего числу текущей даты, на Стр.1, Стр.2, Стр.3.
Заранее благодарю, Лев.
...
Рейтинг: 0 / 0
09.10.2006, 00:27:06
| Ответить | Цитировать | Написать  
Нужна помощь
    #34042246
KL (XL)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
KL (XL)
Участник
Если не сложно, выложи файл с примерами данных, структуры книги и ожидаемым результатом. А то описание слишком навороченное - времени нет разбираться :-)

KL
[MVP - Microsoft Excel]
...
Рейтинг: 0 / 0
09.10.2006, 16:40:30
| Ответить | Цитировать | Написать  
Нужна помощь
    #34042873
Лев
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Лев
Гость
Высылаю пример файла.
Лев.
...
Рейтинг: 0 / 0
09.10.2006, 20:45:15
| Ответить | Цитировать | Написать  
Нужна помощь
    #34042911
KL (XL)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
KL (XL)
Участник
Попробуй так:

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
Sub test()
    Dim i As Long, col As Long
    Dim arrSheets, arrCells
    
    col = Day(Sheets("Отчет").[C1]) +  2 
    arrSheets = Array("МСК-1", "ЦМ", "МСЦ-3")
    arrCells = Array("A3", "D3", "G3")
    
    Application.ScreenUpdating = False
    Sheets("Отчет").[A3:G65536].ClearContents
    For i = LBound(arrSheets) To UBound(arrSheets)
        On Error Resume Next
        With Sheets(arrSheets(i))
            Set rng = Intersect( _
                .Columns(col).SpecialCells(xlCellTypeConstants).EntireRow, _
                Union(.Columns( 1 ), .Columns( 2 ), .Columns(col)))
        End With
        On Error GoTo  0 
        If Not rng Is Nothing Then rng.Copy Sheets("Отчет").Range(arrCells(i))
    Next i
    Application.ScreenUpdating = True
End Sub

KL
[MVP - Microsoft Excel]
...
Рейтинг: 0 / 0
09.10.2006, 21:21:58
| Ответить | Цитировать | Написать  
Нужна помощь
    #34042921
KL (XL)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
KL (XL)
Участник
пардон, исправленный код:

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
Sub test()
    Dim i As Long, col As Long
    Dim arrSheets, arrCells
    Dim rng As Range
    
    col = Day(Sheets("Отчет").[C1]) +  2 
    arrSheets = Array("МСК-1", "ЦМ", "МСЦ-3")
    arrCells = Array("A3", "D3", "G3")
    
    Application.ScreenUpdating = False
    Sheets("Отчет").[A3:I65536].ClearContents
    For i = LBound(arrSheets) To UBound(arrSheets)
        On Error Resume Next
        With Sheets(arrSheets(i))
            Set rng = Intersect( _
                .Columns(col).SpecialCells(xlCellTypeConstants).EntireRow, _
                Union(.Columns( 1 ), .Columns( 2 ), .Columns(col)))
        End With
        On Error GoTo  0 
        If Not rng Is Nothing Then rng.Copy Sheets("Отчет").Range(arrCells(i))
        Set rng = Nothing
    Next i
    Application.ScreenUpdating = True
End Sub


KL
[MVP - Microsoft Excel]д
...
Рейтинг: 0 / 0
09.10.2006, 21:28:19
| Ответить | Цитировать | Написать  
Нужна помощь
    #34045650
Лев
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Лев
Гость
Спасибо за макрос. Он работает, но я бы хотел обратное действие, т.е. из Листа("Отчет") данные необходимо перенести в соответствующие ячейки Листа("МСК-1"), Листа("ЦМ"), Листа("МСЦ-3")
Заранее спасибо Лев
...
Рейтинг: 0 / 0
10.10.2006, 20:57:52
| Ответить | Цитировать | Написать  
Нужна помощь
    #34045689
KL (XL)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
KL (XL)
Участник
ЛевСпасибо за макрос. Он работает, но я бы хотел обратное действие, т.е. из Листа("Отчет") данные необходимо перенести в соответствующие ячейки Листа("МСК-1"), Листа("ЦМ"), Листа("МСЦ-3")
Заранее спасибо ЛевТогда так:

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
Sub test()
    Dim i As Long, col As Long
    Dim rng As Range, c As Range
    Dim arrSheets
    
    col = Day(Sheets("Отчет").[C1]) +  2 
    arrSheets = Array("МСЦ-3", "ЦМ", "МСК-1")
    
    Application.ScreenUpdating = False
    For i = LBound(arrSheets) To UBound(arrSheets)
        With Sheets("Отчет")
            Set rng = .Range(.[A3], .[A65536].End(xlUp)).Offset(, i *  3 )
        End With
        On Error Resume Next
        For Each c In rng
            With Sheets(arrSheets(i))
                Intersect(.Columns(col), .[A:A].Find(c).EntireRow) = c.Offset(,  2 )
            End With
        Next c
        On Error GoTo  0 
        Set rng = Nothing
    Next i
    Application.ScreenUpdating = True
End Sub
...
Рейтинг: 0 / 0
10.10.2006, 21:33:26
| Ответить | Цитировать | Написать  
Нужна помощь
    #34045789
Лев
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Лев
Гость
Большое спасибо, нет слов. Чувствую себя таким чайником. Погружаюсь в Basic.
Еще раз спасибо Лев.
...
Рейтинг: 0 / 0
10.10.2006, 23:53:55
| Ответить | Цитировать | Написать  
Нужна помощь
    #34045791
k-nike2
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
k-nike2
Гость
ЛевЕще раз спасибо Лев.
Хм... Сам себя не похвалишь - никто не похвалит.))
...
Рейтинг: 0 / 0
10.10.2006, 23:55:29
| Ответить | Цитировать | Написать  
Нужна помощь
    #34045930
Фотография orunbek
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
orunbek
Участник
k-nike2 ЛевЕще раз спасибо Лев.
Хм... Сам себя не похвалишь - никто не похвалит.))
...
Рейтинг: 0 / 0
11.10.2006, 06:55:23
| Ответить | Цитировать | Написать  
10 сообщений из 10, страница 1 из 1
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Нужна помощь
Найденые пользователи ...
Разблокировать пользователей ...
Читали тему (0):
Читали форум (0):
Пользователи онлайн (0):
Польз. соглашение   Полит. конфиден.  
NoSQL.ru       Кролег: Проекты, Новости, Чат       РЕД ФОРУМ       Фотоальбом: Участники, Встречи
Закрыть
start [/forum/topic.php?fid=61&msg=34042921&tid=2184155]:
 0ms
get settings:
 5ms
get forum list:
 15ms
check forum access:
 3ms
check topic access:
 3ms
track hit:
 49ms
get topic data:
 9ms
get forum data:
 3ms
get page messages:
 44ms
get tp. blocked users:
 1ms
others: 209ms
total:  341ms
созд. / загр.: 341ms
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]