Duas macros VB simples.
- Criar uma nova pasta de trabalho ativada para macro
- Crie as duas macro abaixo.
- Criar adicionar alguns valores para algumas células
- Executar a macro
DeselectCell - Primeiro, selecione o intervalo inteiro que você deseja fornecer. Se estiver usando a Tabela de exemplo do Excel abaixo, insira:
$A$1:$F$6e pressione OK. - Agora, você precisa especificar quais células deseja selecionar. Basta clicar com o botão esquerdo para especificar um intervalo. (Pressione Ctrl e clique com o botão esquerdo para ter vários intervalos a serem desmarcados. Exemplo, insira:
$A$1,$C$2,$C$6e pressione OK.
- Primeiro, selecione o intervalo inteiro que você deseja fornecer. Se estiver usando a Tabela de exemplo do Excel abaixo, insira:
- Neste ponto, você deve ter uma desmarque a área ativa como na imagem acima. Agora, basta executar a macro CopyMultipleSelection e especificar em qual célula você deseja colar os resultados. No nosso caso, digamos
$A$9, sua tabela copiada final será:
Tabela final colada : (Você terá uma célula vazia em vez de uma _, é somente por causa de problemas de formatação.
_ 4 1 2 3 4
d a _ 6 7 8
f 9 11 1 1 121
a 21 1 12 12 sa
b a a sd a sa
324 234 _ 23 423 42
Exemplo de tabela do Excel : canto superior esquerdo é a célula A1 e canto inferior direito é a célula F6
1 4 1 2 3 4
d a 5 6 7 8
f 9 11 1 1 121
a 21 1 12 12 sa
b a a sd a sa
324 234 234 23 423 42
Macros
Sub DeselectCell()
Dim rng As Range
Dim InputRng As Range
Dim DeleteRng As Range
Dim OutRng As Range
xTitleId = "DeselectCell"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Range :", xTitleId, InputRng.Address, Type:=8)
Set DeleteRng = Application.InputBox("Delete Range", xTitleId, Type:=8)
For Each rng In InputRng
If Application.Intersect(rng, DeleteRng) Is Nothing Then
If OutRng Is Nothing Then
Set OutRng = rng
Else
Set OutRng = Application.Union(OutRng, rng)
End If
End If
Next
OutRng.Select
End Sub
Sub CopyMultipleSelection()
Dim SelAreas() As Range
Dim PasteRange As Range
Dim UpperLeft As Range
Dim NumAreas As Integer, i As Integer
Dim TopRow As Long, LeftCol As Integer
Dim RowOffset As Long, ColOffset As Integer
Dim NonEmptyCellCount As Integer
' Exit if a range is not selected
If TypeName(Selection) <> "Range" Then
MsgBox "Select the range to be copied. A multiple selection is allowed."
Exit Sub
End If
' Store the areas as separate Range objects
NumAreas = Selection.Areas.Count
ReDim SelAreas(1 To NumAreas)
For i = 1 To NumAreas
Set SelAreas(i) = Selection.Areas(i)
Next
' Determine the upper left cell in the multiple selection
TopRow = ActiveSheet.Rows.Count
LeftCol = ActiveSheet.Columns.Count
For i = 1 To NumAreas
If SelAreas(i).Row < TopRow Then TopRow = SelAreas(i).Row
If SelAreas(i).Column < LeftCol Then LeftCol = SelAreas(i).Column
Next
Set UpperLeft = Cells(TopRow, LeftCol)
' Get the paste address
On Error Resume Next
Set PasteRange = Application.InputBox _
(Prompt:="Specify the upper left cell for the paste range:", _
Title:="Copy Mutliple Selection", _
Type:=8)
On Error GoTo 0
' Exit if canceled
If TypeName(PasteRange) <> "Range" Then Exit Sub
' Make sure only the upper left cell is used
Set PasteRange = PasteRange.Range("A1")
' Check paste range for existing data
NonEmptyCellCount = 0
For i = 1 To NumAreas
RowOffset = SelAreas(i).Row - TopRow
ColOffset = SelAreas(i).Column - LeftCol
NonEmptyCellCount = NonEmptyCellCount + _
Application.CountA(Range(PasteRange.Offset(RowOffset, ColOffset), _
PasteRange.Offset(RowOffset + SelAreas(i).Rows.Count - 1, _
ColOffset + SelAreas(i).Columns.Count - 1)))
Next i
' If paste range is not empty, warn user
If NonEmptyCellCount <> 0 Then _
If MsgBox("Overwrite existing data?", vbQuestion + vbYesNo, _
"Copy Multiple Selection") <> vbYes Then Exit Sub
' Copy and paste each area
For i = 1 To NumAreas
RowOffset = SelAreas(i).Row - TopRow
ColOffset = SelAreas(i).Column - LeftCol
SelAreas(i).Copy PasteRange.Offset(RowOffset, ColOffset)
Next i
End Sub