Josy, baseando e adaptando uma outra rotina que te passei em um outro tópico e pelo que entendi neste, ficaria da seguinte forma :
Option Explicit
Dim sDisciplina
Sub CopiaColaColunas()
Dim sEnd As String
Dim sEnd2 As String
Dim nRow As Integer
Dim iNiRow As Long
Dim vArr
Dim ColunasSolicitadas As Variant
Dim Col
Dim GetColumnLt As String
Application.ScreenUpdating = False
Sheets("Serie").Activate
iNiRow = 15 'Linha inicial para copiar
nRow = 11 'linha de titulos
'Carregando Array das colunas B, G, L, Q, V, AA, AF, AK
ColunasSolicitadas = Array(2, 7, 12, 17, 22, 27, 32, 37)
For Each Col In ColunasSolicitadas 'Para cada coluna
sDisciplina = Cells(nRow, Col).Value
sEnd = Cells(iNiRow, Col + 1).Address(0, 0)
sEnd2 = Cells(iNiRow, Col + 3).Address(0, 0)
'Decompõe o endereço para a letra da Coluna
vArr = Split(Cells(iNiRow, Col + 3).Address(True, False), "$")
GetColumnLt = vArr(0)
'Copia
Sheets("Serie").Range(sEnd, Range(GetColumnLt & Rows.Count).End(xlUp)).Copy
Call ColaFolhaCriterio
Application.CutCopyMode = False
Next Col
Sheets("Folha").Activate
Range("B1").Activate
Application.ScreenUpdating = True
End Sub
Sub ColaFolhaCriterio()
Dim lgTtColunas As Long
Dim iCol As Long
Dim myCol As String
Dim linPaste As Long
Dim GetColumnCola As String
Dim vArr
Sheets("Folha").Activate
'Conta as colunas preenchidas
lgTtColunas = Cells(3, Columns.Count).End(xlToLeft).Column
linPaste = 6 'Linha inicial para colar
For iCol = 4 To lgTtColunas
'Verifica os titulos das colunas
If Cells(3, iCol).Value = sDisciplina Then 'Se coincidir
'Decompõe o endereço para a letra da Coluna
vArr = Split(Cells(3, iCol).Address(True, False), "$")
GetColumnCola = vArr(0)
'Cola
Range(GetColumnCola & linPaste).PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
Sheets("Serie").Activate
Exit Sub
End If
Next iCol
End Sub
Sub LimpaFolha()
Sheets("Folha").Range("D6:AA75").ClearContents
End Sub
Veja a aplicação no modelo que enviou, e se analisar as rotinas verá que da para ajustar para mais colunas tambem.
Copiar e Colar Colunas de acordo com um determinada ordem
Se não for isto, favor avisar.
[]s
Postado : 07/10/2015 11:05 am