EXCELer Tudo sobre EXCEL em Português
No último post, vimos como se podiam colar dados na Folha2 provenientes da Folha1. Mas e se os dados a serem colados forem provenientes de selecções múltiplas, ou seja, de ranges não contínuos? Como efectuar estas cópias múltiplas e como colar na Folha2 , mas de modo contínuo, linha a linha?
Para uma melhor compreensão, vejamos o exemplo:
Escolha na Folha1:
Resultado na Folha2:
O Código:
Para o Command Button:
Private Sub Teste_Click()
Call Faz_Tudo
End Sub
Num módulo VBE:
Option Explicit
Sub Faz_Tudo()
Dim LotsOfRanges() As Range
Dim rangeCtr As Long
Dim myRange As Range
Dim myArea As Range
Dim i As Long
Dim destrange As Range
rangeCtr = 0
Do
On Error Resume Next
Set myRange = Nothing
Set myRange = Application.InputBox(prompt:="Seleccionar o Range" _
& rangeCtr + 1, _
Title:="Any Range", _
Default:=Selection.Address, _
Type:=8)
On Error GoTo 0
If myRange Is Nothing Then
'Cancelamento pelo utilizador
Exit Do
Else
rangeCtr = rangeCtr + 1
ReDim Preserve LotsOfRanges(1 To rangeCtr)
Set LotsOfRanges(rangeCtr) = myRange
End If
Loop
If rangeCtr = 0 Then
'Cancela o primeiro e sai
Exit Sub
End If
If MsgBox("Pronto para processar os Ranges?", vbYesNo) = vbNo Then
Exit Sub
End If
For i = LBound(LotsOfRanges) To UBound(LotsOfRanges)
For Each myArea In LotsOfRanges(i).Areas
Set destrange = Sheets("Sheet2").Range("A" & _
LastRow(Sheets("Sheet2")) + 1)
myArea.Copy
destrange.PasteSpecial xlPasteValues, , False, False
Application.CutCopyMode = False
Next myArea
Next i
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function