none
Copiar e colar baseado em 3 condições diferentes RRS feed

  • Pergunta

  • Preciso de alguma formar copiar os itens de uma planilha para a outra levando em consideração 3 condições diferentes. 

    O que fiz foi: 

    Do While Not IsEmpty(Sheets("Base").Cells(linha, colunaTime))
                If Sheets("Base").Cells(linha, colunaProjeto).Value = ComboBoxProjeto.Value Then
                    If CDate(Sheets("Base").Cells(linha, colunaAtualização).Value) = CDate(ComboBoxAtualização.Value) Then
                        If DatePart("h", CDate(Sheets("Base").Cells(linha, colunaTime).Value)) = DatePart("h", CDate(ComboBoxTime.Value)) Then
                            Sheets("Report").Range("M15").Value = Sheets("Base").Cells(linha, colunaDP).Value
                            Sheets("Report").Range("M10").Value = Sheets("Base").Cells(linha, colunaDR).Value
                            Sheets("Report").Range("Q15").Value = Sheets("Base").Cells(linha, colunaMdP).Value
                            Sheets("Report").Range("Q10").Value = Sheets("Base").Cells(linha, colunaMdR).Value
                            Sheets("Report").Range("U15").Value = Sheets("Base").Cells(linha, colunaAP).Value
                            Sheets("Report").Range("U10").Value = Sheets("Base").Cells(linha, colunaAR).Value
                            Sheets("Report").Range("Y15").Value = Sheets("Base").Cells(linha, colunaMP).Value
                            Sheets("Report").Range("Y10").Value = Sheets("Base").Cells(linha, colunaMR).Value
                            Sheets("Report").Range("AC15").Value = Sheets("Base").Cells(linha, colunaCP).Value
                            Sheets("Report").Range("AC10").Value = Sheets("Base").Cells(linha, colunaCR).Value
                            Sheets("Report").Range("C18").Value = Sheets("Base").Cells(linha, colunaObjetivo).Value
                            Sheets("Report").Range("Q18").Value = Sheets("Base").Cells(linha, colunaAtividadesRealizadas).Value
                            Sheets("Report").Range("C26").Value = Sheets("Base").Cells(linha, colunaProximasAtividades).Value
                            Sheets("Report").Range("Q26").Value = Sheets("Base").Cells(linha, colunaProblemasRiscosEncontrados).Value
                            Sheets("Report").Range("D6").Value = TextBoxID.Value
                            Sheets("Report").Range("F6").Value = ComboBoxProjeto.Value
                            Sheets("Report").Range("C5").Value = ComboBoxLider.Value
                        End If
                    End If
                End If
                linha = linha + 1
            Loop
        
    Porém está muito "pesado" o código e acaba travando o excel.  Acham que tem algum outro jeito mais fácil de fazer?

    segunda-feira, 20 de março de 2017 19:28

Respostas

  • Tente usar DoEvents para não afogar os processos do Excel ao rodar o código VBA.

    Além disso, reescrevi algumas partes do seu código para melhorar a leitura.

    Dim wsBase As Worksheet
    Dim wsReport As Worksheet
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set wsBase = ThisWorkbook.Worksheets("Base")
    Set wsReport = ThisWorkbook.Worksheets("Report")
    
    Do While Not IsEmpty(wsBase.Cells(linha, colunaTime))
        If wsBase.Cells(linha, colunaProjeto).Value <> ComboBoxProjeto.Value Then GoTo continue
        If CDate(wsBase.Cells(linha, colunaAtualização).Value) <> CDate(ComboBoxAtualização.Value) Then GoTo continue
        If DatePart("h", CDate(wsBase.Cells(linha, colunaTime).Value)) <> DatePart("h", CDate(ComboBoxTime.Value)) Then GoTo continue
        
        wsReport.Range("M15").Value = wsBase.Cells(linha, colunaDP).Value
        wsReport.Range("M10").Value = wsBase.Cells(linha, colunaDR).Value
        wsReport.Range("Q15").Value = wsBase.Cells(linha, colunaMdP).Value
        wsReport.Range("Q10").Value = wsBase.Cells(linha, colunaMdR).Value
        wsReport.Range("U15").Value = wsBase.Cells(linha, colunaAP).Value
        wsReport.Range("U10").Value = wsBase.Cells(linha, colunaAR).Value
        wsReport.Range("Y15").Value = wsBase.Cells(linha, colunaMP).Value
        wsReport.Range("Y10").Value = wsBase.Cells(linha, colunaMR).Value
        wsReport.Range("AC15").Value = wsBase.Cells(linha, colunaCP).Value
        wsReport.Range("AC10").Value = wsBase.Cells(linha, colunaCR).Value
        wsReport.Range("C18").Value = wsBase.Cells(linha, colunaObjetivo).Value
        wsReport.Range("Q18").Value = wsBase.Cells(linha, colunaAtividadesRealizadas).Value
        wsReport.Range("C26").Value = wsBase.Cells(linha, colunaProximasAtividades).Value
        wsReport.Range("Q26").Value = wsBase.Cells(linha, colunaProblemasRiscosEncontrados).Value
        wsReport.Range("D6").Value = TextBoxID.Value
        wsReport.Range("F6").Value = ComboBoxProjeto.Value
        wsReport.Range("C5").Value = ComboBoxLider.Value
                End If
            End If
        End If
        If linha Mod 100 = 0 Then DoEvents
        linha = linha + 1
    Loop
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    


    http://www.ambienteoffice.com.br || Grupo de WhatsApp: https://chat.whatsapp.com/K1uey5Q4yJdKnsgWkVQAZG

    • Marcado como Resposta Thiago Krebs segunda-feira, 8 de maio de 2017 16:54
    segunda-feira, 20 de março de 2017 21:52
    Moderador

Todas as Respostas

  • Tente usar DoEvents para não afogar os processos do Excel ao rodar o código VBA.

    Além disso, reescrevi algumas partes do seu código para melhorar a leitura.

    Dim wsBase As Worksheet
    Dim wsReport As Worksheet
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set wsBase = ThisWorkbook.Worksheets("Base")
    Set wsReport = ThisWorkbook.Worksheets("Report")
    
    Do While Not IsEmpty(wsBase.Cells(linha, colunaTime))
        If wsBase.Cells(linha, colunaProjeto).Value <> ComboBoxProjeto.Value Then GoTo continue
        If CDate(wsBase.Cells(linha, colunaAtualização).Value) <> CDate(ComboBoxAtualização.Value) Then GoTo continue
        If DatePart("h", CDate(wsBase.Cells(linha, colunaTime).Value)) <> DatePart("h", CDate(ComboBoxTime.Value)) Then GoTo continue
        
        wsReport.Range("M15").Value = wsBase.Cells(linha, colunaDP).Value
        wsReport.Range("M10").Value = wsBase.Cells(linha, colunaDR).Value
        wsReport.Range("Q15").Value = wsBase.Cells(linha, colunaMdP).Value
        wsReport.Range("Q10").Value = wsBase.Cells(linha, colunaMdR).Value
        wsReport.Range("U15").Value = wsBase.Cells(linha, colunaAP).Value
        wsReport.Range("U10").Value = wsBase.Cells(linha, colunaAR).Value
        wsReport.Range("Y15").Value = wsBase.Cells(linha, colunaMP).Value
        wsReport.Range("Y10").Value = wsBase.Cells(linha, colunaMR).Value
        wsReport.Range("AC15").Value = wsBase.Cells(linha, colunaCP).Value
        wsReport.Range("AC10").Value = wsBase.Cells(linha, colunaCR).Value
        wsReport.Range("C18").Value = wsBase.Cells(linha, colunaObjetivo).Value
        wsReport.Range("Q18").Value = wsBase.Cells(linha, colunaAtividadesRealizadas).Value
        wsReport.Range("C26").Value = wsBase.Cells(linha, colunaProximasAtividades).Value
        wsReport.Range("Q26").Value = wsBase.Cells(linha, colunaProblemasRiscosEncontrados).Value
        wsReport.Range("D6").Value = TextBoxID.Value
        wsReport.Range("F6").Value = ComboBoxProjeto.Value
        wsReport.Range("C5").Value = ComboBoxLider.Value
                End If
            End If
        End If
        If linha Mod 100 = 0 Then DoEvents
        linha = linha + 1
    Loop
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    


    http://www.ambienteoffice.com.br || Grupo de WhatsApp: https://chat.whatsapp.com/K1uey5Q4yJdKnsgWkVQAZG

    • Marcado como Resposta Thiago Krebs segunda-feira, 8 de maio de 2017 16:54
    segunda-feira, 20 de março de 2017 21:52
    Moderador
  • Tente usar DoEvents para não afogar os processos do Excel ao rodar o código VBA.

    Além disso, reescrevi algumas partes do seu código para melhorar a leitura.

    Dim wsBase As Worksheet
    Dim wsReport As Worksheet
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set wsBase = ThisWorkbook.Worksheets("Base")
    Set wsReport = ThisWorkbook.Worksheets("Report")
    
    Do While Not IsEmpty(wsBase.Cells(linha, colunaTime))
        If wsBase.Cells(linha, colunaProjeto).Value <> ComboBoxProjeto.Value Then GoTo continue
        If CDate(wsBase.Cells(linha, colunaAtualização).Value) <> CDate(ComboBoxAtualização.Value) Then GoTo continue
        If DatePart("h", CDate(wsBase.Cells(linha, colunaTime).Value)) <> DatePart("h", CDate(ComboBoxTime.Value)) Then GoTo continue
        
        wsReport.Range("M15").Value = wsBase.Cells(linha, colunaDP).Value
        wsReport.Range("M10").Value = wsBase.Cells(linha, colunaDR).Value
        wsReport.Range("Q15").Value = wsBase.Cells(linha, colunaMdP).Value
        wsReport.Range("Q10").Value = wsBase.Cells(linha, colunaMdR).Value
        wsReport.Range("U15").Value = wsBase.Cells(linha, colunaAP).Value
        wsReport.Range("U10").Value = wsBase.Cells(linha, colunaAR).Value
        wsReport.Range("Y15").Value = wsBase.Cells(linha, colunaMP).Value
        wsReport.Range("Y10").Value = wsBase.Cells(linha, colunaMR).Value
        wsReport.Range("AC15").Value = wsBase.Cells(linha, colunaCP).Value
        wsReport.Range("AC10").Value = wsBase.Cells(linha, colunaCR).Value
        wsReport.Range("C18").Value = wsBase.Cells(linha, colunaObjetivo).Value
        wsReport.Range("Q18").Value = wsBase.Cells(linha, colunaAtividadesRealizadas).Value
        wsReport.Range("C26").Value = wsBase.Cells(linha, colunaProximasAtividades).Value
        wsReport.Range("Q26").Value = wsBase.Cells(linha, colunaProblemasRiscosEncontrados).Value
        wsReport.Range("D6").Value = TextBoxID.Value
        wsReport.Range("F6").Value = ComboBoxProjeto.Value
        wsReport.Range("C5").Value = ComboBoxLider.Value
                End If
            End If
        End If
        If linha Mod 100 = 0 Then DoEvents
        linha = linha + 1
    Loop
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True


    http://www.ambienteoffice.com.br || Grupo de WhatsApp: https://chat.whatsapp.com/K1uey5Q4yJdKnsgWkVQAZG

    Onde que entra o continue em seu código
    • Editado Thiago Krebs terça-feira, 21 de março de 2017 12:54
    terça-feira, 21 de março de 2017 12:52
  • Esse aqui seria o código completo desta parte da macro.

    Private Sub ButtonEnviar_Click()
    
    
    Dim linha As Integer, colunaProjeto As Integer, colunaObjetivo As Integer
    Dim oDictionary As Object, colunaSprojeto As Integer, colunaKPI As Integer, colunaGF As Integer
    Dim colunaDP As Integer, colunaDR As Integer, colunaMdP As Integer, colunaMdR As Integer, colunaAP As Integer
    Dim colunaAR As Integer, colunaMP As Integer, colunaMR As Integer, colunaCP As Integer, colunaCR As Integer
    Dim colunaAtividadesRealizadas As Integer, colunaProximasAtividades As Integer, colunaProblemasRiscosEncontrados As Integer
    Dim wsBase As Worksheet
    Dim wsReport As Worksheet
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set wsBase = ThisWorkbook.Worksheets("Base")
    Set wsReport = ThisWorkbook.Worksheets("Report")
        Set oDictionary = CreateObject("Scripting.Dictionary")
        linha = 3
        colunaProjeto = 6
        colunaObjetivo = 45
        colunaKPI = 37
        colunaGF = 40
        colunaDP = 13
        colunaDR = 14
        colunaMdP = 15
        colunaMdR = 16
        colunaAP = 17
        colunaAR = 18
        colunaMP = 19
        colunaMR = 20
        colunaCP = 21
        colunaCR = 22
        colunaAtividadesRealizadas = 25
        colunaProximasAtividades = 27
        colunaProblemasRiscosEncontrados = 28
    
        
    
    On Error Resume Next
    
    Do While Not IsEmpty(wsBase.Cells(linha, colunaTime))
        If wsBase.Cells(linha, colunaProjeto).Value <> ComboBoxProjeto.Value Then GoTo continue
            If CDate(wsBase.Cells(linha, colunaAtualização).Value) <> CDate(ComboBoxAtualização.Value) Then GoTo continue
                If DatePart("h", CDate(wsBase.Cells(linha, colunaTime).Value)) <> DatePart("h", CDate(ComboBoxTime.Value)) Then GoTo continue
                    wsReport.Range("M15").Value = wsBase.Cells(linha, colunaDP).Value
                    wsReport.Range("M10").Value = wsBase.Cells(linha, colunaDR).Value
                    wsReport.Range("Q15").Value = wsBase.Cells(linha, colunaMdP).Value
                    wsReport.Range("Q10").Value = wsBase.Cells(linha, colunaMdR).Value
                    wsReport.Range("U15").Value = wsBase.Cells(linha, colunaAP).Value
                    wsReport.Range("U10").Value = wsBase.Cells(linha, colunaAR).Value
                    wsReport.Range("Y15").Value = wsBase.Cells(linha, colunaMP).Value
                    wsReport.Range("Y10").Value = wsBase.Cells(linha, colunaMR).Value
                    wsReport.Range("AC15").Value = wsBase.Cells(linha, colunaCP).Value
                    wsReport.Range("AC10").Value = wsBase.Cells(linha, colunaCR).Value
                    wsReport.Range("C18").Value = wsBase.Cells(linha, colunaObjetivo).Value
                    wsReport.Range("Q18").Value = wsBase.Cells(linha, colunaAtividadesRealizadas).Value
                    wsReport.Range("C26").Value = wsBase.Cells(linha, colunaProximasAtividades).Value
                    wsReport.Range("Q26").Value = wsBase.Cells(linha, colunaProblemasRiscosEncontrados).Value
                    wsReport.Range("D6").Value = TextBoxID.Value
                    wsReport.Range("F6").Value = ComboBoxProjeto.Value
                    wsReport.Range("C5").Value = ComboBoxLider.Value
        If linha Mod 100 = 0 Then DoEvents
        linha = linha + 1
    Loop
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
                       
    End Sub

    terça-feira, 21 de março de 2017 13:24
  • Remova a instrução On Error Resume Next.

    E qual foi sua última pergunta?


    http://www.ambienteoffice.com.br || Grupo de WhatsApp: https://chat.whatsapp.com/K1uey5Q4yJdKnsgWkVQAZG

    terça-feira, 21 de março de 2017 22:43
    Moderador
  • Remova a instrução On Error Resume Next.

    E qual foi sua última pergunta?


    http://www.ambienteoffice.com.br || Grupo de WhatsApp: https://chat.whatsapp.com/K1uey5Q4yJdKnsgWkVQAZG

    Obrigado!!
    quarta-feira, 22 de março de 2017 12:45