ReSQL.ru
     
powered by simpleCommunicator - 2.0.61     © 2026 Programmizd 02
Мобильная версия    Контакт    Правила    FAQ    Помощь
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Доб. в избранное | Игнор. тему | Прикреп. тему | Пометить прочит. / непрочит. | Фильтр
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Переделать макрос. Поможете?
9 сообщений из 9, страница 1 из 1
Переделать макрос. Поможете?
    #35644118
Сергей06
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Сергей06
Участник
Задача:
Выделенную область скопировать в буфер обмена, перед этим добавив в к правым выделенным ячейкам " руб.". Если ячейка пуста (не содержит число) то подставлять не нужно.
Вот такое наваял такое:

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
Sub Подставить_руб()
Dim Адрес As Variant, СтолбецПравый As Integer, СтолбецЛевый As Integer, СтрокаПервая As Integer, СтрокаПоследняя As Integer
' Range("B3:E6").Select
' Нужно выделить более одной ячвейки.
 Адрес = Selection.Address(ReferenceStyle:=xlR1C1, RowAbsolute:=True)
 СтолбецПравый = Mid(Mid(Адрес, InStr(Адрес, "C") +  1 ), InStr(Mid(Адрес, InStr(Адрес, "C") +  1 ), "C") +  1 )
 СтолбецЛевый = Left(Mid(Адрес, InStr(Адрес, "C") +  1 ), InStr(Mid(Адрес, InStr(Адрес, "C") +  1 ), ":") -  1 )
 СтрокаПервая = Mid(Адрес, InStr(Адрес, "R") +  1 , InStr(Адрес, "C") -  2 )
 СтрокаПоследняя = Mid(Mid(Mid(Адрес, InStr(Адрес, "R") +  1 ), InStr(Mid(Адрес, InStr(Адрес, "R") +  1 ), "R") +  1 ), _
  1 , InStr(Mid(Mid(Адрес, InStr(Адрес, "R") +  1 ), InStr(Mid(Адрес, InStr(Адрес, "R") +  1 ), "R") +  1 ), "C") -  1 )
 
 Range(Cells(СтрокаПервая, СтолбецПравый +  1 ), Cells(СтрокаПоследняя, СтолбецПравый +  1 )).FormulaR1C1 = "=RC[-1]&"" руб."""
 Range(Cells(СтрокаПервая, СтолбецПравый +  1 ), Cells(СтрокаПоследняя, СтолбецПравый +  1 )).Copy
 Cells(СтрокаПервая, СтолбецПравый +  1 ).PasteSpecial xlPasteValues
 Range(Cells(СтрокаПервая, СтолбецПравый +  1  -  1 ), Cells(СтрокаПоследняя, СтолбецПравый +  1  -  1 )).ClearContents
 Range(Cells(СтрокаПервая, СтолбецЛевый +  1  -  1 ), Cells(СтрокаПоследняя, СтолбецПравый +  1 )).Copy

End Sub
:-)
Поможете переделать?
...
Рейтинг: 0 / 0
10.11.2008, 14:44:43
| Ответить | Цитировать | Написать  
Переделать макрос. Поможете?
    #35644455
Aster32
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Aster32
Гость
Sub RUR_Addition()

B = Selection.Columns.Count

For i = 1 To Selection.Rows.Count
If Selection.Cells(i, B).Value <> "" Then Selection.Cells(i, B).Value = Selection.Cells(i, B).Value & " руб."
Next i

Selection.Copy

End Sub
...
Рейтинг: 0 / 0
10.11.2008, 16:19:38
| Ответить | Цитировать | Написать  
Переделать макрос. Поможете?
    #35644497
PlanB
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
PlanB
Участник
Тогда уж вот так:
Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
Sub aaa()
For I% =  1  To Selection.Columns.Count
    For J% =  1  To Selection.Rows.Count
        If Selection.Cells(J, I).Value <> "" Then
            Selection.Cells(J, I).Value = Selection.Cells(J, I).Value & " руб."
        End If
    Next
Next
    Selection.Copy
End Sub
...
Рейтинг: 0 / 0
10.11.2008, 16:35:09
| Ответить | Цитировать | Написать  
Переделать макрос. Поможете?
    #35644567
Aster32
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Aster32
Гость
Так вроде требовалось добавить руб. только к правым ячейкам выделенной области?
...
Рейтинг: 0 / 0
10.11.2008, 16:55:38
| Ответить | Цитировать | Написать  
Переделать макрос. Поможете?
    #35644704
PlanB
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
PlanB
Участник
Сергей06добавив в к правым выделенным ячейкам " руб." Не прочитал.
Но как-то глупо, согласитесь... уже или к каждой, или по порядку выделенные непустые ячейки раскладывать.
Сдаётся мне, что в буфер надо с "руб." записывать, а исходные ячейки не менять. Тогда в массив засовывать придётся. Но смысл, думаю, понятен...
...
Рейтинг: 0 / 0
10.11.2008, 17:39:14
| Ответить | Цитировать | Написать  
Переделать макрос. Поможете?
    #35645648
Сергей06
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Сергей06
Участник
Aster32,PlanB,
спасибо, все действительно оказалось проще, чем я наколбасил. :-)

PlanB
Сдаётся мне, что в буфер надо с "руб." записывать, а исходные ячейки не менять. Тогда в массив засовывать придётсяДа, правильно. Хотя и не принципиально на сегодняшний день.
а как в массив засунуть ?
...
Рейтинг: 0 / 0
11.11.2008, 09:58:12
| Ответить | Цитировать | Написать  
Переделать макрос. Поможете?
    #35645754
Aster32
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Aster32
Гость
автора как в массив засунуть ?

Смотря в какой.

Если в двумерный - можно так:

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
Sub Read_to_2d_array()

Dim Data_array() As Variant
Dim RowN As Integer, ColumnN As Integer
Dim i As Integer, j As Integer

With Selection
    RowN = .Rows.Count
    ColumnN = .Columns.Count
    ReDim Data_array(RowN, ColumnN)
    For i =  1  To RowN
        For j =  1  To ColumnN
            Data_array(i, j) = .Cells(i, j).Value
        Next j
    Next i
End With

End Sub

Если в одномерный - можно так:

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
Sub Read_to_1d_array()

Dim Data_array() As Variant
Dim CellN As Integer
Dim i As Integer

With Selection
    CellN = .Rows.Count * .Columns.Count
    ReDim Data_array(CellN)
    For i =  1  To CellN
        Data_array(i) = .Cells(i).Value
    Next i
End With

End Sub
...
Рейтинг: 0 / 0
11.11.2008, 10:36:33
| Ответить | Цитировать | Написать  
Переделать макрос. Поможете?
    #35646022
_slan_
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
_slan_
Участник
а бастрее так
dim arr
arr=selection
...
Рейтинг: 0 / 0
11.11.2008, 11:36:43
| Ответить | Цитировать | Написать  
Переделать макрос. Поможете?
    #35646140
A-Nik
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
A-Nik
Гость
Сергей06,
Вот ещё 2 варианта:
Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
Sub Var1()
Dim Sel As Range, LastCol As Range
Set Sel = Selection: Set LastCol = Sel.Offset(, Sel.Columns.Count).Resize(,  1 )
LastCol = "=IF(RC[-1],RC[-1]&"" руб."",RC[-1]&"""")"
LastCol.Copy: LastCol.Offset(, - 1 ).PasteSpecial xlPasteValues
LastCol.ClearContents: Sel.Copy
End Sub

Sub Var2()
Selection.Offset(, Selection.Columns.Count).Resize(,  1 ) = "=IF(RC[-1],RC[-1]&"" руб."",RC[-1]&"""")"
Union(Selection.Resize(, Selection.Columns.Count -  1 ), Selection.Offset(, Selection.Columns.Count).Resize(,  1 )).Copy
End Sub
...
Рейтинг: 0 / 0
11.11.2008, 12:01:30
| Ответить | Цитировать | Написать  
9 сообщений из 9, страница 1 из 1
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Переделать макрос. Поможете?
Найденые пользователи ...
Разблокировать пользователей ...
Читали тему (0):
Читали форум (0):
Пользователи онлайн (0):
Польз. соглашение   Полит. конфиден.  
NoSQL.ru       Кролег: Проекты, Новости, Чат       РЕД ФОРУМ       Фотоальбом: Участники, Встречи
Закрыть
start [/forum/topic.php?fid=61&msg=35644497&tid=2180175]:
 0ms
get settings:
 10ms
get forum list:
 22ms
check forum access:
 3ms
check topic access:
 3ms
track hit:
 239ms
get topic data:
 7ms
get forum data:
 2ms
get page messages:
 35ms
get tp. blocked users:
 1ms
others: 239ms
total:  561ms
созд. / загр.: 561ms
x
x
Закрыть


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