Помогите с макросом в Excel / Microsoft Office

ReSQL.ru

Мобильная версия Контакт Правила FAQ Помощь

Гость

Войти | Регистрация | Профиль | Очистить

Новые сообщения | Избранное

Форумы | Пользователи | Статистика | Мод. лог | Поиск

Цитировать

Написать

Автор*:

Ввести пароль для входа

Тема*:

Сообщение

Данное сообщение тематическое

Сообщение содержит картинки или видео 18+

Автор:

ВНИМАНИЕ! На данном подфоруме действуют строгие правила. Удостоверьтесь, что ваше сообщение соответствует им!

Форум или тема закрыты для гостей. Необходима авторизация!

Загрузить последнюю сохраненную версию

Вложение:

Вставить как галерею

Максимальный размер вложений: 4,0 МБ, аудио/видео: 8,0 МБ. Картинки большего размера ужимаются, если возможно.

Введите код, изображенный на картинке. Если код нечитаемый, кликните картинку, чтобы загрузить другой вариант.

Отправляя сообщение, я выражаю свое согласие с правилами форума и принимаю пользовательское соглашение.

Доб. в избранное | Игнор. тему | Прикреп. тему | Пометить прочит. / непрочит. | Фильтр

Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Помогите с макросом в Excel

8 сообщений из 8, страница 1 из 1

Помогите с макросом в Excel

#36297342

Passat

Гость

Друзья, помогите кто может! Нужно создать макрос, с помощью которого можно сделать следующее:
На одном листе находятся данные, на другом листе
необходимо создать таблицы, соответствующие следующим критериям:
первая таблица должна содержать данные о работниках со специальностями
Слесарь и Электрик, и у которых Признаки№1 и №2 больше нуля, или хотябы один из признаков больше нуля.
Вторая таблица должна
содержать данные о работниках со специальностями Бухгалтер и Главный
бухгалтер, и у которых Признаки№1 и №2 больше нуля, или хотябы один из
признаков больше нуля. Третья таблица должна содержать данные о работниках
со специальностями Директор и Зам. директора, и у которых Признаки№1 и №2
больше нуля, или хотябы один из признаков больше нуля с выводом
этих признаков в таблицу.
В прикрепленном файле более наглядней представлено, что я хочу.
Заранее благодарен:))

...

Рейтинг:

0 / 0

08.11.2009, 17:00

| Ответить | Цитировать | Написать

Помогите с макросом в Excel

#36297651

Hugo121

Гость

Т.к. есть косяк в исходных данных - "Зам. Директора" в таблице и "Зам. директора" в условии, в макросе добавил UCase.
Ну и т.к. нужны рамки, код немного распух. Завтра попробую подсократить, пока так.

Код: 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.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.

Sub product()
With Application
    calc_status = .Calculation
    .Calculation = xlManual
    .ScreenUpdating = False

Sheets("Результат").Activate
Set blank_cell = Sheets("Результат").Cells(Range("a1").SpecialCells(xlCellTypeLastCell).Row +  2 ,  1 )
x = blank_cell.Row -  1 

For Each cc In Sheets("Исх. данные").UsedRange.Columns( 4 ).Cells
    If UCase(Trim(cc.Value)) = "СЛЕСАРЬ" Or UCase(Trim(cc.Value)) = "ЭЛЕКТРИК" And (cc.Offset( 0 , - 1 ) + cc.Offset( 0 , - 2 ) <>  0 ) Then
    Range(Sheets("Исх. данные").Cells(cc.Row,  1 ), Sheets("Исх. данные").Cells(cc.Row,  3 )).Copy blank_cell
    Set blank_cell = Sheets("Результат").Cells(Range("a1").SpecialCells(xlCellTypeLastCell).Row +  1 ,  1 )
    End If
Next
y = blank_cell.Row -  1 

Set rrr = Sheets("Результат").Range("A" & x & ":C" & y)

    With rrr.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rrr.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rrr.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rrr.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rrr.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rrr.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

Set blank_cell = Sheets("Результат").Cells(Range("a1").SpecialCells(xlCellTypeLastCell).Row +  3 ,  1 )
x = blank_cell.Row -  1 
For Each cc In Sheets("Исх. данные").UsedRange.Columns( 4 ).Cells
    If UCase(Trim(cc.Value)) = "БУХГАЛТЕР" Or UCase(Trim(cc.Value)) = "ГЛАВНЫЙ БУХГАЛТЕР" And (cc.Offset( 0 , - 1 ) + cc.Offset( 0 , - 2 ) <>  0 ) Then
    Range(Sheets("Исх. данные").Cells(cc.Row,  1 ), Sheets("Исх. данные").Cells(cc.Row,  3 )).Copy blank_cell
    Set blank_cell = Sheets("Результат").Cells(Range("a1").SpecialCells(xlCellTypeLastCell).Row +  1 ,  1 )
    End If
Next
y = blank_cell.Row -  1 

Set rrr = Sheets("Результат").Range("A" & x & ":C" & y)

    With rrr.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rrr.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rrr.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rrr.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rrr.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rrr.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

Set blank_cell = Sheets("Результат").Cells(Range("a1").SpecialCells(xlCellTypeLastCell).Row +  3 ,  1 )
x = blank_cell.Row -  1 
For Each cc In Sheets("Исх. данные").UsedRange.Columns( 4 ).Cells
    If UCase(Trim(cc.Value)) = "ДИРЕКТОР" Or UCase(Trim(cc.Value)) = "ЗАМ. ДИРЕКТОРА" And (cc.Offset( 0 , - 1 ) + cc.Offset( 0 , - 2 ) <>  0 ) Then
    Range(Sheets("Исх. данные").Cells(cc.Row,  1 ), Sheets("Исх. данные").Cells(cc.Row,  3 )).Copy blank_cell
    Set blank_cell = Sheets("Результат").Cells(Range("a1").SpecialCells(xlCellTypeLastCell).Row +  1 ,  1 )
    End If
Next
y = blank_cell.Row -  1 
Set rrr = Sheets("Результат").Range("A" & x & ":C" & y)

    With rrr.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rrr.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rrr.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rrr.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rrr.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rrr.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    
    

   .Calculation = calc_status
   .ScreenUpdating = True
 End With
End Sub

...

Рейтинг:

0 / 0

08.11.2009, 23:24

| Ответить | Цитировать | Написать

Помогите с макросом в Excel

#36297894

Hugo121

Гость

Сделал покороче - вынес рамки в отдельную функцию. Ну и заменил "<> 0" на "> 0", так правильнее (вдруг будут отрицательные признаки?).

...

Рейтинг:

0 / 0

09.11.2009, 09:04

| Ответить | Цитировать | Написать

Помогите с макросом в Excel

#36299313

Passat

Гость

Ребят, спасибо. То что надо! Вообще я мега-проект делаю, где и условий будет больше и колонок в итоговых таблицах))))

...

Рейтинг:

0 / 0

09.11.2009, 16:57

| Ответить | Цитировать | Написать

Помогите с макросом в Excel

#36318536

Passat

Гость

Подогнал макрос под свой проект. Добавил столбцов с данными. Но макрос отрабатывает только по критериям должностей, а условие, что данные в определенных столбцах должны быть больше нуля игнорируются=( В чем ошибка?

...

Рейтинг:

0 / 0

18.11.2009, 23:42

| Ответить | Цитировать | Написать

Помогите с макросом в Excel

#36318834

Hugo121

Гость

Нашёл - поставь OR в скобки:

Код: plaintext

    If (UCase(Trim(cc.Value)) = "СЛЕСАРЬ" Or UCase(Trim(cc.Value)) = "ЭЛЕКТРИК") And (cc.Offset( 0 , - 1 ) + cc.Offset( 0 , - 3 )) >  0  Then

Но там другое вскрылось - проблема с заданием рамок если мало значений, похоже если y = blank_cell.Row - 1 меньше 1, то проблема. Надо подкрутить...

...

Рейтинг:

0 / 0

19.11.2009, 09:15

| Ответить | Цитировать | Написать

Помогите с макросом в Excel

#36319088

Hugo121

Гость

Глянул пристальнее - проблема была в другом...
Добавил флаг, и в функции рамки условие.
И x = blank_cell.Row - 1 заменил на x = blank_cell.Row
Потестируй получше, мне сейчас некогда, не помню, зачем вначале - 1 было...

Код: plaintext

Sub product()

With Application
    calc_status = .Calculation
    .Calculation = xlManual
    .ScreenUpdating = False

Sheets("Результат").Activate
Set blank_cell = Sheets("Результат").Cells(Range("a1").SpecialCells(xlCellTypeLastCell).Row +  2 ,  1 )
x = blank_cell.Row
flag = False
For Each cc In Sheets("Исх. данные").UsedRange.Columns( 7 ).Cells
    If (UCase(Trim(cc.Value)) = "СЛЕСАРЬ" Or UCase(Trim(cc.Value)) = "ЭЛЕКТРИК") And (cc.Offset( 0 , - 1 ) + cc.Offset( 0 , - 3 )) >  0  Then
    Range(Sheets("Исх. данные").Cells(cc.Row,  1 ), Sheets("Исх. данные").Cells(cc.Row,  7 )).Copy blank_cell
    Set blank_cell = Sheets("Результат").Cells(Range("a1").SpecialCells(xlCellTypeLastCell).Row +  1 ,  1 )
    flag = True
    End If
Next
y = blank_cell.Row -  1 

If flag Then ramki x, y

Set blank_cell = Sheets("Результат").Cells(Range("a1").SpecialCells(xlCellTypeLastCell).Row +  2 ,  1 )
x = blank_cell.Row
flag = False
For Each cc In Sheets("Исх. данные").UsedRange.Columns( 7 ).Cells
    If (UCase(Trim(cc.Value)) = "БУХГАЛТЕР" Or UCase(Trim(cc.Value)) = "ГЛАВНЫЙ БУХГАЛТЕР") And (cc.Offset( 0 , - 1 ) + cc.Offset( 0 , - 3 )) >  0  Then
    Range(Sheets("Исх. данные").Cells(cc.Row,  1 ), Sheets("Исх. данные").Cells(cc.Row,  7 )).Copy blank_cell
    Set blank_cell = Sheets("Результат").Cells(Range("a1").SpecialCells(xlCellTypeLastCell).Row +  1 ,  1 )
    flag = True
    End If
Next
y = blank_cell.Row -  1 

If flag Then ramki x, y

Set blank_cell = Sheets("Результат").Cells(Range("a1").SpecialCells(xlCellTypeLastCell).Row +  2 ,  1 )
x = blank_cell.Row
flag = False
For Each cc In Sheets("Исх. данные").UsedRange.Columns( 7 ).Cells
    If (UCase(Trim(cc.Value)) = "ДИРЕКТОР" Or UCase(Trim(cc.Value)) = "ЗАМ. ДИРЕКТОРА") And (cc.Offset( 0 , - 1 ) + cc.Offset( 0 , - 3 )) >  0  Then
    Range(Sheets("Исх. данные").Cells(cc.Row,  1 ), Sheets("Исх. данные").Cells(cc.Row,  7 )).Copy blank_cell
    Set blank_cell = Sheets("Результат").Cells(Range("a1").SpecialCells(xlCellTypeLastCell).Row +  1 ,  1 )
    flag = True
    End If
Next
y = blank_cell.Row -  1 
    
If flag Then ramki x, y

   .Calculation = calc_status
   .ScreenUpdating = True
 End With
End Sub

Function ramki(ByVal xx As Long, ByVal yy As Long)
Set rrr = Sheets("Результат").Range("A" & xx & ":G" & yy)

    With rrr.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rrr.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rrr.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rrr.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rrr.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    
    If yyy > xxx Then
        With rrr.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
    End If
    
End Function

...

Рейтинг:

0 / 0

19.11.2009, 11:07

| Ответить | Цитировать | Написать

Помогите с макросом в Excel

#36319607

Passat

Гость

Спасибо!!!

...

Рейтинг:

0 / 0

19.11.2009, 13:17

| Ответить | Цитировать | Написать

8 сообщений из 8, страница 1 из 1

Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Помогите с макросом в Excel

Читали тему (0):

Читали форум (0):

Пользователи онлайн (0):

start [/forum/topic.php?fid=61&tid=2178821]:	0ms
get settings:	7ms
get forum list:	17ms
check forum access:	3ms
check topic access:	3ms
track hit:	175ms
get topic data:	13ms
get forum data:	3ms
get page messages:	48ms
get tp. blocked users:	2ms
others:	202ms

total:	473ms

	Необходимые cookie
	Cookie для сбора статистики
	Cookie для маркетинга и рекламы