Segue arquivo..

http://www.sendspace.com/file/wv5jwd

Sub Transferir()

Dim ws As Worksheet
Dim i As Integer
Dim j As Integer
Dim lin As Long
Dim slin As Long
Dim elin As Long

Set ws = Sheets("BASE")
i = ws.Index + 1
j = Sheets.Count
elin = 2

Do While i <= j
lin = 2
slin = Sheets(i).Range("A1048576").End(xlUp).Row
Do While lin <= slin
ws.Cells(elin, 1) = Sheets(i).Cells(lin, 2)
ws.Cells(elin, 2) = Sheets(i).Cells(lin, 3)
ws.Cells(elin, 3) = Sheets(i).Cells(lin, 4)
ws.Cells(elin, 4) = Sheets(i).Cells(lin, 5)
ws.Cells(elin, 5) = Sheets(i).Cells(lin, 7)
ws.Cells(elin, 6) = Sheets(i).Cells(lin, 9)
ws.Cells(elin, 7) = Sheets(i).Cells(lin, 10)
ws.Cells(elin, 8) = Sheets(i).Cells(lin, 11)
ws.Cells(elin, 9) = Sheets(i).Cells(lin, 15)
ws.Cells(elin, 10) = Sheets(i).Cells(lin, 19)
ws.Cells(elin, 11) = Sheets(i).Cells(lin, 20)
ws.Cells(elin, 12) = Sheets(i).Cells(lin, 22)
ws.Cells(elin, 13) = Sheets(i).Cells(lin, 23)
lin = lin + 1
elin = elin + 1
Loop
i = i + 1
Loop
End Sub

muito obrigado

Vou testar e falo se deu certo