JayBhagavan, да, не заметил под кодом
ну вот так можно (потренировал коллекции, использовал немного код
Маугли)
Сортируем Areas по первым столбцам, убираем или обрезаем первую Area, остальное объединяем.
Скрытый текст |
---|
Код |
---|
Sub tt()
Dim r As Range, rr As Range, n, i&, ArCol As New Collection
Set r = Selection 'Range("D1:D10, B1:B10, F1:G10, A1:A10")
If r.Areas.Count = 1 Then If r.Columns.Count = 1 Then Exit Sub
i = 0
For Each n In r.Areas
If i > n.Columns(1).Column Then
If ArCol.Count > 0 Then
ArCol.Add n, , 1
Else
ArCol.Add n
End If
i = n.Columns(1).Column
Else
ArCol.Add n
If i = 0 Then i = n.Columns(1).Column
End If
Next
If ArCol.Count > 1 Then
If ArCol(1).Columns.Count = 1 Then
Set rr = ArCol(2)
Else
Set rr = ArCol(1).Offset(, 1).Resize(, ArCol(1).Columns.Count - 1)
End If
For i = 2 To ArCol.Count
Set rr = Union(rr, ArCol(i))
Next
Else
Set rr = ArCol(1).Offset(, 1).Resize(, ArCol(1).Columns.Count - 1)
End If
rr.Select
MsgBox "Input: " & r.Address & vbCrLf & _
"Output: " & rr.Address & vbCrLf & " Removed: " & ArCol(1).Columns(1).Address
End Sub |
|
Можно и проще - выясняем, в какой Area наименьший номер первого столбца, запоминаем порядковый номер этой Area, а затем объединяем в новый Range все остальные Areas + обрезанная запомненная.
Скрытый текст |
---|
Код |
---|
Sub tt2()
Dim r As Range, rr As Range, n, i&, ArCol As New Collection
Set r = Selection 'Range("D1:D10, B1:B10, F1:G10, A1:A10")
If r.Areas.Count = 1 Then If r.Columns.Count = 1 Then Exit Sub
i = 0
Dim k
For n = 1 To r.Areas.Count
If i > r.Areas(n).Columns(1).Column Then
i = r.Areas(n).Columns(1).Column
k = n
ElseIf i = 0 Then
i = r.Areas(n).Columns(1).Column
k = n
End If
Next
For i = 1 To r.Areas.Count
If i = k Then
If r.Areas(i).Columns.Count > 1 Then
If rr Is Nothing Then
Set rr = r.Areas(i).Offset(, 1).Resize(, r.Areas(i).Columns.Count - 1)
Else
Set rr = Union(rr, r.Areas(i).Offset(, 1).Resize(, r.Areas(i).Columns.Count - 1))
End If
End If
ElseIf rr Is Nothing Then
Set rr = r.Areas(i)
Else
Set rr = Union(rr, r.Areas(i))
End If
Next
rr.Select
MsgBox "Input: " & r.Address & vbCrLf & _
"Output: " & rr.Address & vbCrLf & " Removed: " & r.Areas(k).Columns(1).Address
End Sub |
|
Единственно, если в первом слева столбце будет два выделения, уберется первое... Но это мне уже лень дорисовывать.