Версия для слабовидящих
Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

 

= Мир MS Excel/Макрос "Selection_eXchange" - Мир MS Excel

  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, китин, DrMini  
Макрос "Selection_eXchange"
Alex_ST Дата: Понедельник, 30.08.2010, 13:24 | Сообщение № 1
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3219
Репутация: 622 ±
Замечаний: 0% ±

2003
Макрос Selection_eXchange позволяет обменять местами ТЕКСТ двух выбранных диапазонов или выделенных областей

Sub Selection_eXchange()
    If Not TypeName(Selection) = "Range" Then Exit Sub
    Dim tmpVar1, tmpVar2
    Dim tmpRng1 As Range, tmpRng2 As Range
    With Selection
        Select Case .Areas.Count
        Case 1   ' выделена 1 область
            If .Count = 2 Then   ' выделено 2 ячейки
                Set tmpRng1 = .Cells(1): Set tmpRng2 = .Cells(2)
            ElseIf .Rows.Count = 2 And .Columns.Count > 2 Then  ' выделен горизонтальный диапазон в 2 строки
                Set tmpRng1 = Range(Cells(.Row, .Column), Cells(.Row, .Column + .Columns.Count - 1))   ' 1-я строка диапазона
                Set tmpRng2 = tmpRng1.Offset(1, 0)   ' 2-я строка ниже на 1
            ElseIf .Columns.Count = 2 And .Rows.Count > 2 Then    ' выделен вертикальный диапазон в 2 столбца
                Set tmpRng1 = Range(Cells(.Row, .Column), Cells(.Row + .Rows.Count - 1, .Column))  ' 1-й столбец
                Set tmpRng2 = tmpRng1.Offset(0, 1)   ' 2-й столбец правее на 1
            Else: Exit Sub
            End If
        Case 2   ' выделено 2 области
            If .Areas(1).Columns.Count = .Areas(2).Columns.Count And _
                .Areas(1).Rows.Count = .Areas(2).Rows.Count Then   ' одинаковая размерность областей
                Set tmpRng1 = .Areas(1): Set tmpRng2 = .Areas(2)
            End If
        Case Else: Exit Sub
        End Select
    End With
    Application.ScreenUpdating = False: Application.EnableEvents = False
    tmpVar1 = tmpRng1: tmpVar2 = tmpRng2
    tmpRng1.Value = tmpVar2: tmpRng2.Value = tmpVar1
    Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub




С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеМакрос Selection_eXchange позволяет обменять местами ТЕКСТ двух выбранных диапазонов или выделенных областей
[vba]
Sub Selection_eXchange()      If Not ТypeЧame(Selection) = "Range" Then Exit Sub      Dim tmpVar1; tmpVar2      Dim tmpRng1 As Range; tmpRng2 As Range      With Selection         Select Case .Areas.Count            Case 1   ' выделена 1 область               If .Count = 2 Then   ' выделено 2 ячейки                  Set tmpRng1 = .Cells(1): Set tmpRng2 = .Cells(2)               ElseIf .Rows.Count = 2 And .Columns.Count > 2 Then  ' выделен горизонтальный диапазон в 2 строки                  Set tmpRng1 = Range(Cells(.Row; .Column); Cells(.Row; .Column + .Columns.Count - 1))   ' 1-я строка диапазона                  Set tmpRng2 = tmpRng1.Offset(1; 0)   ' 2-я строка ниже на 1               ElseIf .Columns.Count = 2 And .Rows.Count > 2 Then    ' выделен вертикальный диапазон в 2 столбца                  Set tmpRng1 = Range(Cells(.Row; .Column); Cells(.Row + .Rows.Count - 1; .Column))  ' 1-й столбец                  Set tmpRng2 = tmpRng1.Offset(0; 1)   ' 2-й столбец правее на 1               Else: Exit Sub               End If            Case 2   ' выделено 2 области               If .Areas(1).Columns.Count = .Areas(2).Columns.Count And _                  .Areas(1).Rows.Count = .Areas(2).Rows.Count Then   ' одинаковая размерность областей                  Set tmpRng1 = .Areas(1): Set tmpRng2 = .Areas(2)               End If            Case Else: Exit Sub         End Select      End With      Application.ScreenUpdating = False: Application.EnableEvents = False      tmpVar1 = tmpRng1: tmpVar2 = tmpRng2      tmpRng1.Value = tmpVar2: tmpRng2.Value = tmpVar1      Application.EnableEvents = Тrue: Application.ScreenUpdating = Тrue End Sub
[/vba]

Автор - Alex_ST
Дата добавления - 30.08.2010 в 13:24
  • Страница 1 из 1
  • 1
Поиск:

Рейтинг@Mail.ru Яндекс.Метрика Яндекс цитирования
© 2010-2025 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!