Aqui não deu erro, mas em vez de fazer várias colunas ao mesmo tempo, você pode copiar uma coluna, colar, copiar outra coluna, colar...
Private Sub Workbook_Open()
'Abre a pasta receptora que está salva no mesmo local em que esta pasta está salva
'Já foi testado e funcionou
Workbooks.Open (ThisWorkbook.Path & "Pasta Receptora.xlsm")
Dim wkb As Workbook
'wkb passa a ser a pasta receptora
Set wkb = ActiveWorkbook
'ultima linha do intervalo doador
Dim ulinha As Long
ulinha = ThisWorkbook.Sheets("Plan1").UsedRange.Rows.Count
'++++++++++++++++ATENÇÃO+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'ativando a pasta doadora
ThisWorkbook.Activate
'selecionando a planilha doadora
ThisWorkbook.Sheets("Plan1").Select
'selecionando o intervalo doador
'ThisWorkbook.Sheets("Plan1").Range("H2:H" & ulinha & ",K2:K" & ulinha & ",M2:M" & ulinha & ",W2:W" & ulinha & ",X2:X" & ulinha & ",Y2:Y" & ulinha & ",O2:O" & ulinha & ",P2:P" & ulinha & ",J2:J" & ulinha & ",S2:S" & ulinha & ",A2:A" & ulinha & ",AI2:AI" & ulinha & ",AJ2:AJ" & ulinha).Select
ThisWorkbook.Sheets("Plan1").Range("H2:H" & ulinha).Select
'copiando o intervalo doador
Selection.Copy
'ativando pasta receptora
wkb.Activate
'selecionando planilha receptora
wkb.Sheets("Plan1").Select
'selecionando a célula receptora
wkb.Sheets("Plan1").Range("E9").Select
'colando
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'++++++++++++++++ATENÇÃO+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'ativando a pasta doadora
ThisWorkbook.Activate
'selecionando a planilha doadora
ThisWorkbook.Sheets("Plan1").Select
'selecionando o intervalo doador
'ThisWorkbook.Sheets("Plan1").Range("H2:H" & ulinha & ",K2:K" & ulinha & ",M2:M" & ulinha & ",W2:W" & ulinha & ",X2:X" & ulinha & ",Y2:Y" & ulinha & ",O2:O" & ulinha & ",P2:P" & ulinha & ",J2:J" & ulinha & ",S2:S" & ulinha & ",A2:A" & ulinha & ",AI2:AI" & ulinha & ",AJ2:AJ" & ulinha).Select
ThisWorkbook.Sheets("Plan1").Range("K2:K" & ulinha).Select
'copiando o intervalo doador
Selection.Copy
'ativando pasta receptora
wkb.Activate
'selecionando planilha receptora
wkb.Sheets("Plan1").Select
'selecionando a célula receptora
wkb.Sheets("Plan1").Range("F9").Select
'colando
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'++++++++++++++++ATENÇÃO+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'REPITA PARA AS
'OUTRAS
'COLUNAS
'ISSO É UMA GAMBIARRA POR
'ESTAR DANDO ERRO AÍ
'++++++++++++++++++++++++++++++++++++++++ FINAL+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'tirando a seleção
Application.CutCopyMode = False
'salvando a pasta receptora
wkb.Save
'fechando a pasta receptora
wkb.Close
End Sub
Postado : 25/01/2018 4:57 pm