Prezados, boa noite,

Realizei uma macro para transferir dados de uma aba para outra com linhas especificas, porém quando começa a rodar a parte 2 a mesma esta travando constantemente e não consigo rodar até o final. Alguém poderia me ajudar a melhorar a mesma para que eu consiga rodar a planilha.

Muito grato pela ajuda

Sub Atualização()
 
'Limpeza das Aba Sheets
'===============================
Sheets("Base CMD").Select
Range("I2:J1000000").Select
    Selection.ClearContents
    
Sheets("5 Status").Select
Range("A2:I1000000").Select
    Selection.ClearContents
    
Sheets("Cont.").Select
Range("A2:I1000000").Select
    Selection.ClearContents
    
Sheets("Apoio").Select
Range("C2:J1000000").Select
    Selection.ClearContents
    

'Ajuste da Base CMD
'==============================
Sheets("Base CMD").Select
Range("I2").Select
ActiveCell.Formula = "=IF(H2=""In Yard"",""Sim"",IF(H2=""To Plant"",""Sim"",IF(H2=""Pouring"",""Sim"",IF(H2=""Arrive Job"",""Sim"",IF(H2=""To Job"",""Sim"","""")))))"
Range("I2").AutoFill Destination:=Range("I2:I" & Cells(Rows.Count, 1).End(xlUp).Row)

'Caso queira tirar a formula e colar so o resultado
Range("i2:i" & Cells(Rows.Count, 1).End(xlUp).Row).Value = Range("i2:i" & Cells(Rows.Count, 1).End(xlUp).Row).Value
 
 
'Transferir dados da Aba Base CMD para 5 Status
'===============================================
 Dim LinhaAtual As Long
 Dim UltimaLinha As Long
 Dim W As Worksheet
 Dim Linha As Integer
 
 
 Set W = Sheets("Base CMD")
 
 UltimaLinha = W.UsedRange.Rows.Count
 
 Linha = 2
 
 With W
 For LinhaAtual = 1 To UltimaLinha
 
 If Cells(LinhaAtual, "I") = "Sim" Then
 
 'If Cells(LinhaAtual, "I") = "Sim" Or _
 'Cells(LinhaAtual, "C") = "EM ANDAMENTO" Then
 
 Sheets("5 Status").Cells(Linha, 1) = .Cells(LinhaAtual, 1)
 Sheets("5 Status").Cells(Linha, 2) = .Cells(LinhaAtual, 2)
 Sheets("5 Status").Cells(Linha, 3) = .Cells(LinhaAtual, 3)
 Sheets("5 Status").Cells(Linha, 4) = .Cells(LinhaAtual, 4)
 Sheets("5 Status").Cells(Linha, 5) = .Cells(LinhaAtual, 5)
 Sheets("5 Status").Cells(Linha, 6) = .Cells(LinhaAtual, 6)
 Sheets("5 Status").Cells(Linha, 7) = .Cells(LinhaAtual, 7)
 Sheets("5 Status").Cells(Linha, 8) = .Cells(LinhaAtual, 8)
 Sheets("5 Status").Cells(Linha, 9) = .Cells(LinhaAtual, 9)
  
'Sheets("5 Status").Cells(Linha, 2) = Format(.Cells(LinhaAtual, 2), "DD/MM/YYYY")
'Sheets("5 Status).Cells(Linha, 5) = Format(.Cells(LinhaAtual, 5), "currency")
  
 Linha = Linha + 1
 '.Rows(LinhaAtual).Delete
 
 Else
 
 End If
 
 Next LinhaAtual
 
 End With
 
 
'Ajuste da Base CMD parte2
'==============================
 
Sheets("Base CMD").Select
Range("J2").Select
ActiveCell.Formula = "=IF(H2=""Auto Status Ticket Packet"",""Sim"",IF(H2=""Auto Status Ticket Cancel Packet"",""Sim"",IF(H2=""Auto Status Ticket Change Packet"",""Sim"","""")))"
Range("J2").AutoFill Destination:=Range("J2:J" & Cells(Rows.Count, 1).End(xlUp).Row)

'Caso queira tirar a formula e colar so o resultado
Range("j2:j" & Cells(Rows.Count, 1).End(xlUp).Row).Value = Range("j2:j" & Cells(Rows.Count, 1).End(xlUp).Row).Value
 
'Transferir dados da Aba Base CMD para Apoio
'===============================================
 Dim LinhaAtual1 As Long
 Dim UltimaLinha1 As Long
 Dim W1 As Worksheet
 Dim Linha1 As Integer

 Set W1 = Sheets("Base CMD")
 
 UltimaLinha1 = W1.UsedRange.Rows.Count
 
 Linha1 = 2
 
 With W1
 For LinhaAtual1 = 1 To UltimaLinha1
 
 If Cells(LinhaAtual1, "J") = "Sim" Then
 'após linha atual colocar a coluna
 
 'If Cells(LinhaAtual, "I") = "Sim" Or _
 'Cells(LinhaAtual, "C") = "EM ANDAMENTO" Then
 
 Sheets("Apoio").Cells(Linha1, 3) = .Cells(LinhaAtual1, 1)
 Sheets("Apoio").Cells(Linha1, 4) = .Cells(LinhaAtual1, 2)
 Sheets("Apoio").Cells(Linha1, 5) = .Cells(LinhaAtual1, 3)
 Sheets("Apoio").Cells(Linha1, 6) = .Cells(LinhaAtual1, 4)
 Sheets("Apoio").Cells(Linha1, 7) = .Cells(LinhaAtual1, 5)
 Sheets("Apoio").Cells(Linha1, 8) = .Cells(LinhaAtual1, 6)
 Sheets("Apoio").Cells(Linha1, 9) = .Cells(LinhaAtual1, 7)
 Sheets("Apoio").Cells(Linha1, 10) = .Cells(LinhaAtual1, 8)
   
'Sheets("5 Status").Cells(Linha, 2) = Format(.Cells(LinhaAtual, 2), "DD/MM/YYYY")
'Sheets("5 Status).Cells(Linha, 5) = Format(.Cells(LinhaAtual, 5), "currency")
  
 Linha1 = Linha1 + 1
 '.Rows(LinhaAtual).Delete
 
 Else
 
 End If
 Next LinhaAtual1
 
 End With


End Sub