| Descricao: |
 Saberexcel - site das macros
Esta Macro do Aplicativo Microsoft Excel VBA, separa determinados dados e transfere para outra planilha
Option Explicit
Sub Transfere_Transforma_Dados()
Dim vLivro As Workbook
Dim vPlanDados As Worksheet, vPlanAuxiliar As Worksheet
Dim vRangeUnica As Range, vRangeInicial As Range, rnData As Range
Dim rnFilter As Range, rnFind As Range, rnSource As Range
Dim vaField As Variant
Dim i As Long, j As Long
Set vLivro = ThisWorkbook
With vLivro
Set vPlanDados = .Worksheets("Pagamento")
Set vPlanAuxiliar = .Worksheets("Auxiliar")
End With
With vPlanDados
Set vRangeUnica = .Range(.Range("C1"), .Range("C65536").End(xlUp))
Set rnSource = .Range(.Range("C2"), .Range("C65536").End(xlUp))
Set rnFilter = .Range(.Range("A1"), .Range("D65536").End(xlUp))
Set rnData = .Range("A1")
End With
With vPlanAuxiliar
Set vRangeInicial = .Range("A1")
End With
Application.ScreenUpdating = False
'First we sort the table.
rnFilter.Sort Key1:=Range("C2"), _
Order1:=xlAscending, _
Header:=xlGuess, _
Ordercustom:=1, _
MatchCase:=True, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
' Then we create the unique collection of fieldnames.
vRangeUnica.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=vRangeUnica, _
CopyToRange:=Range("J1"), _
Unique:=True
'Read the unique collection into an array.
With vPlanDados
vaField = .Range(.Range("J2"), .Range("J65536").End(xlUp))
End With
With vRangeInicial
.Value = "Request_ID"
'Add the collection to the first row in the target-worksheet.
.Offset(0, 1).Resize(1, UBound(vaField)).Value = Application.Transpose(vaField)
'Add the Request-ID numbers to the first column in the target-worksheet.
.Offset(1, 0).Resize(vRangeUnica.Rows.Count, 1).Value = vRangeUnica.Offset(1, -2).Value
End With
'Loop through the collection, set the condition and finally
'transfer the data into the target-worksheet.
For i = 1 To UBound(vaField)
rnData.AutoFilter Field:=3, Criteria1:=vaField(i, 1)
Set rnFind = rnSource.SpecialCells(xlCellTypeVisible)
j = rnFind.Rows.Count
vRangeInicial.Offset(1, i).Resize(j, 1).Value = rnFind.Offset(0, 1).Value
Next i
vPlanDados.AutoFilterMode = False
Application.ScreenUpdating = False
MsgBox "Concluido"
End Sub
Aprenda tudo sobre o Aplicativo Microsoft Excel VBA, sozinho, praticando com os produtos didáticos Saberexcel
|