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

ReSQL.ru

2.0.61

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

Гость

Войти | Профиль | Очистить

Нов. | Гор. | Избр.

Написать

Автор*:

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

Тема*:

Сообщение

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

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

Автор:

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

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

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

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

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

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

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

Действия ...

Доб. в избранное
Игнор. тему
Прикреп. тему
Пометить прочит. / непрочит.
Фильтр:
Сообщения автора темы
Сообщение содержит вложения
Сообщение содержит картинки
Сообщение содержит видеоклипы
Сообщение содержит аудиоклипы
Сообщение содержит картинки или видео 18+

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

08.11.2009, 17:00

#36297342

Passat

Гость

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

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

...

Рейтинг:

0 / 0

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

08.11.2009, 23:24

#36297651

Hugo121

Гость

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

Т.к. есть косяк в исходных данных - "Зам. Директора" в таблице и "Зам. директора" в условии, в макросе добавил 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

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

09.11.2009, 09:04

#36297894

Hugo121

Гость

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

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

...

Рейтинг:

0 / 0

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

09.11.2009, 16:57

#36299313

Passat

Гость

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

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

...

Рейтинг:

0 / 0

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

18.11.2009, 23:42

#36318536

Passat

Гость

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

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

...

Рейтинг:

0 / 0

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

19.11.2009, 09:15

#36318834

Hugo121

Гость

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

Нашёл - поставь 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, 11:07

#36319088

Hugo121

Гость

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

Глянул пристальнее - проблема была в другом...
Добавил флаг, и в функции рамки условие.
И 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, 13:17

#36319607

Passat

Гость

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

Спасибо!!!

...

Рейтинг:

0 / 0

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

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

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

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

start [/forum/topic.php?fid=61&tablet=1&tid=2178821]:	0ms
get settings:	11ms
get forum list:	20ms
check forum access:	4ms
check topic access:	4ms
track hit:	189ms
get topic data:	9ms
get forum data:	2ms
get page messages:	34ms
get tp. blocked users:	1ms
others:	255ms

total:	529ms

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