Excel Agenda eletrônica em vba

[Denisdp]

Boa tarde,

Quero transferir o nome para a tabela 02 conforme referencia da tabela 01, mas esta informação deverá preencher automaticamente quando alterado o número da semana.    
Sempre correspondendo dia da semana e hora    
Poderiam me ajudar com o código?

 

Desde já agradeço pelo suporte.

Att;

 

Denis

Calendário.xlsx

[Muca Costa]

Tente isso:

 

Sub Transferir()
Dim sStatusProcesso As String, A As String, UltimaLinha As String, Lin As String, i As Integer
sStatusProcesso = "Aguarde... O sistema está CONSOLIDANDO as informações. "
Application.StatusBar = sStatusProcesso
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
    
    If Plan1.Range("I2") = "" Then
    MsgBox "Informe a Semana na célula I2", vbInformation, "© Muca Sistemas - 2019"
    Exit Sub
    End If
    
    With ActiveSheet
    A = .Cells(Rows.Count, 5).End(xlUp).Row
    Plan1.Range("G6:L" & A).ClearContents
    End With
    
    UltimaLinha = A
    Lin = 6
    
    For i = 6 To UltimaLinha
        If Plan1.Cells(Lin, 5) = Plan1.Range("I2") Then
           
           If Plan1.Cells(Lin, 1) = Plan1.Range("H4") Then
           Plan1.Cells(Lin, 7) = Plan1.Cells(i, 3)
           Plan1.Cells(Lin, 8) = Plan1.Cells(i, 2)
        
           ElseIf Plan1.Cells(Lin, 1) = Plan1.Range("I4") Then
           Plan1.Cells(Lin, 7) = Plan1.Cells(i, 3)
           Plan1.Cells(Lin, 9) = Plan1.Cells(i, 2)
       
           ElseIf Plan1.Cells(Lin, 1) = Plan1.Range("J4") Then
           Plan1.Cells(Lin, 7) = Plan1.Cells(i, 3)
           Plan1.Cells(Lin, 10) = Plan1.Cells(i, 2)
        
           ElseIf Plan1.Cells(Lin, 1) = Plan1.Range("K4") Then
           Plan1.Cells(Lin, 7) = Plan1.Cells(i, 3)
           Plan1.Cells(Lin, 11) = Plan1.Cells(i, 2)
        
           ElseIf Plan1.Cells(Lin, 1) = Plan1.Range("L4") Then
           Plan1.Cells(Lin, 7) = Plan1.Cells(i, 3)
           Plan1.Cells(Lin, 12) = Plan1.Cells(i, 2)
        
           End If

        Lin = Lin + 1
        
        End If
        
    Next
    
    Plan1.Range("I2").Select
    
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = sStatusProcesso & " Filtro finalizado"
Application.StatusBar = False

End Sub

[Denisdp]

Obrigado.

 

A coluna "G" não ficou com os valores fixados, mas pode deixar que resolvo por aqui.

 

Mais uma vez muito obrigado.

[Muca Costa]

Tem um erro no código, trocar:

De:        Lin = Lin + 1
              End If

Para: End If
          Lin = Lin + 1

===========================================================================

Porém acho que com as macros abaixo, deve funcionar melhor:

 

Sub Transferir()
Dim sStatusProcesso As String, A As String, UltimaLinha As String, Lin As String, i As Integer
sStatusProcesso = "Aguarde... O sistema está CONSOLIDANDO as informações. "
Application.StatusBar = sStatusProcesso
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
    
    If Plan1.Range("I2") = "" Then
    MsgBox "Informe a Semana na célula I2", vbInformation, "© Muca Sistemas - 2019"
    Exit Sub
    End If
    
    With ActiveSheet
    A = .Cells(Rows.Count, 5).End(xlUp).Row
    Plan1.Range("G6:L" & A).ClearContents
    End With
    
    UltimaLinha = A
    Lin = 6
    
    For i = 6 To UltimaLinha
        If Plan1.Cells(Lin, 5) = Plan1.Range("I2") Then
           
           If Plan1.Cells(Lin, 1) = Plan1.Range("H4") Then
           VaiVazia
           Plan1.Cells(Plan1.Range("G4"), 7) = Plan1.Cells(i, 3)
           Plan1.Cells(Plan1.Range("G4"), = Plan1.Cells(i, 2)
        
           ElseIf Plan1.Cells(Lin, 1) = Plan1.Range("I4") Then
           VaiVazia
           Plan1.Cells(Plan1.Range("G4"), 7) = Plan1.Cells(i, 3)
           Plan1.Cells(Plan1.Range("G4"), 9) = Plan1.Cells(i, 2)
       
           ElseIf Plan1.Cells(Lin, 1) = Plan1.Range("J4") Then
           VaiVazia
           Plan1.Cells(Plan1.Range("G4"), 7) = Plan1.Cells(i, 3)
           Plan1.Cells(Plan1.Range("G4"), 10) = Plan1.Cells(i, 2)
        
           ElseIf Plan1.Cells(Lin, 1) = Plan1.Range("K4") Then
           VaiVazia
           Plan1.Cells(Plan1.Range("G4"), 7) = Plan1.Cells(i, 3)
           Plan1.Cells(Plan1.Range("G4"), 11) = Plan1.Cells(i, 2)
        
           ElseIf Plan1.Cells(Lin, 1) = Plan1.Range("L4") Then
           VaiVazia
           Plan1.Cells(Plan1.Range("G4"), 7) = Plan1.Cells(i, 3)
           Plan1.Cells(Plan1.Range("G4"), 12) = Plan1.Cells(i, 2)
        
           End If
        
        End If
        Lin = Lin + 1
        
    Next
    
    Plan1.Range("I2").Select
    
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = sStatusProcesso & " Filtro finalizado"
Application.StatusBar = False
    MsgBox "FIM"

End Sub

 

Sub VaiVazia()
    Dim i As Integer
        i = 5
    Do While Range("G" & i).Value <> ""
        i = i + 1
    Loop
        Range("G" & i).Select
        Plan1.Range("G4") = i
End Sub

[Patropi]

Bom dia @Muca Costa

 

Pare evitar que caracteres do código sejam substituídos por Emoji, ao postar um código VBA, utilize a ferramenta CODE.

 

É só clicar em < > e colar o código dentro.

 

Se foi útil, clique em Curtir.

 

[]s

[Muca Costa]

Valeu Patropi ,

 

Onde está o Emiji, substituir por:

 

Plan1.Cells(Plan1.Range("G4"), 8) = Plan1.Cells(i, 2)