9 - Excel Perguntas e Respostas

Postado por


Tire suas dúvidas sobre Excel básico e avançado.


Nesta página, tiramos as dúvidas de nossos seguidores sobre o Excel em todos os níveis ( do básico ao avançado). As respostas serão feitas por escrito. No entanto, se a resposta for complexa, faremos um vídeo para lhe responder.



1 - Fórmula pode abrir uma MsgBox?

 
CÓDIGOS:
Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.Address <> "$A$1" Then
         Exit Sub
   End If
  
   If Target.Address = "$A$1" And Target.Value = "Carlos" Then
         MsgBox "Você escreveu o nome CARLOS na célula A1."
   End If
End Sub


2 - Como apagar várias linhas obedecendo uma condição usando VBA?

CÓDIGOS:
Sub DeletarVendidosA1()
   For Lin = 4 To 21
       If Cells(Lin, 7).Value = "Pago" Then
           ActiveSheet.Range(Cells(Lin, 2), Cells(Lin, 7)).Select
           Selection.Delete Shift:=xlUp
       End If
   Next Lin

   Range("B4:G4").Select
   Selection.Copy

   Range("B4:G21").Select
   Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
   SkipBlanks:=False, Transpose:=False
   Application.CutCopyMode = False

   Cells(4, 1).Select
End Sub
_______________________________________
Sub DeletarVendidosA2()
   For Lin = 4 To 21
        ActiveSheet.Range(Cells(Lin, 2), Cells(Lin, 7)).Select
        Application.Wait Now + TimeValue("00:00:01")

        If Cells(Lin, 7).Value = "Pago" Then
             Application.Wait Now + TimeValue("00:00:01")
             ActiveSheet.Range(Cells(Lin, 2), Cells(Lin, 7)).Select
             Application.Wait Now + TimeValue("00:00:01")
             Selection.Delete Shift:=xlUp
             Application.Wait Now + TimeValue("00:00:01")
        End If
   Next Lin

   Cells(4, 1).Select
End Sub


2B - Errata ao vídeo "Como apagar várias linhas obedecendo uma condição usando VBA?"

CÓDIGOS:
Sub DeletarVendidosA()
   Dim Lin As Integer
   Dim shtPatio As Worksheet Set shtPatio = Sheets("Pátio")

   For Lin = 4 To 21
A:
      If shtPatio.Cells(Lin, 7).Value = "Pago" Then
          shtPatio.Range(Cells(Lin, 1), Cells(Lin, 7)).Select
          Selection.Delete Shift:=xlUp
          GoTo A:
      End If
   Next Lin

   shtPatio.Cells(4, 1).Select
   Application.CutCopyMode = False 
End Sub


3 - No VBA, como copiar e colar linhas entre abas obedecendo uma condição?

CÓDIGOS:
Sub TransferirVendidos()
    Set shtPatio = Sheets("Pátio")
    Set shtVendidos = Sheets("Vendidos")

    For LinPat = 4 To 21
        If shtPatio.Cells(LinPat, 7).Value = "Vendido" Then 
           For LinVend = 4 To 100
                If shtVendidos.Cells(LinVend, 2).Value = "" Then
                    shtVendidos.Cells(LinVend, 2).Value = shtPatio.Cells(LinPat, 2).Value
                    shtVendidos.Cells(LinVend, 3).Value = shtPatio.Cells(LinPat, 3).Value
                    shtVendidos.Cells(LinVend, 4).Value = shtPatio.Cells(LinPat, 4).Value
                    shtVendidos.Cells(LinVend, 5).Value = shtPatio.Cells(LinPat, 5).Value
                    shtVendidos.Cells(LinVend, 6).Value = shtPatio.Cells(LinPat, 6).Value
                    shtVendidos.Cells(LinVend, 7).Value = shtPatio.Cells(LinPat, 7).Value
                    GoTo Pular1
                End If
           Next LinVend

Pular1:
           shtPatio.Range(Cells(LinPat, 2), shtPatio.Cells(LinPat, 7)).Select
           Selection.Delete Shift:=xlUp
           LinPat = LinPat - 1
        End If
    Next LinPat

     Range("B4:G4").Select
     Selection.Copy

    Range("B4:G21").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Cells(4, 1).Select
End Sub


4 - Como formatar células com VBA? ( Parte 1 )

CÓDIGOS:
Sub FormatarNotas()      Set shtNotas = Sheets("Notas")

     For Lin = 4 To 23          Application.Wait Now + TimeValue("00:00:01")

          If shtNotas.Cells(Lin, 4).Value > 14 Then
            shtNotas.Cells(Lin, 4).Font.ColorIndex = 5
            shtNotas.Cells(Lin, 4).Font.Bold = True
         End If

          If shtNotas.Cells(Lin, 4).Value < 15 Then
            shtNotas.Cells(Lin, 4).Font.ColorIndex = 3
            shtNotas.Cells(Lin, 4).Font.Bold = True
         End If      Next Lin

      Cells(4, 1).Select End Sub
Imagem com os códigos das cores:













5 - Como formatar células com VBA? ( Parte 2 )

CÓDIGOS:
Sub FormatarNotas()
    Set shtNotas = Sheets("Notas")

    For Lin = 4 To 23
           If shtNotas.Cells(Lin, 5).Value = "Inativo" Then
               Range(Cells(Lin, 2), Cells(Lin, 5)).Interior.ColorIndex = 45
          End If

          If shtNotas.Cells(Lin, 4).Value > 14 Then
               shtNotas.Cells(Lin, 4).Font.ColorIndex = 5
               shtNotas.Cells(Lin, 4).Font.Bold = True
          End If

          If shtNotas.Cells(Lin, 4).Value < 15 Then
              shtNotas.Cells(Lin, 4).Font.ColorIndex = 3
             shtNotas.Cells(Lin, 4).Font.Bold = True
          End If
    Next Lin

    Cells(4, 1).Select
End Sub 


6 - Como deletar várias linhas a partir de uma determinada linha? 

CÓDIGOS:
Sub ApagarLinhas1()
     Set shtNotas = Sheets("Notas")
     NuLin = shtNotas.Range("G4").Value

     Set CelIni = Cells(7, 1)
     Set CelFim = Cells(6 + NuLin, 4)

     shtNotas.Range(CelIni, CelFim).Select
     Selection.Delete Shift:=xlUp

     Range("A6").Select
End Sub
_______________________________________
Sub ApagarLinhas2()
    Set shtNotas = Sheets("Notas")
     NumLinAp = shtNotas.Range("G4").Value

     Lin = 1
     Do While Lin < NumLinAp + 1
           Rows(7).Select
           Selection.Delete Shift:=xlUp
           Lin = Lin + 1
     Loop

     Range("A6").Select
End Sub 


7 - Como deletar várias linhas a partir de uma determinada linha?


CÓDIGOS:
Sub Preencher01()
    Lin = 7
    Do While Cells(Lin, 1).Value <> ""
          If Cells(Lin + 1, 1).Value <> "" And Cells(Lin, 2).Value <> "" And Cells(Lin + 1, 2).Value = "" Then
       
              Range(Cells(Lin, 2), Cells(Lin, 5)).Select
              Selection.Copy
       
              Range(Cells(Lin + 1, 2), Cells(Lin + 1, 5)).Select
              ActiveSheet.Paste
              Selection.Font.ColorIndex = 3
       
          End If
       Lin = Lin + 1
    Loop
 
    Range("F1").Select
    Application.CutCopyMode = False
End Sub


8 - Entre abas, copiar e colar somente última linha:


CÓDIGOS:
Sub Trans_Dados01()
    Dim ULin As Integer
    Dim shtTabA As Worksheet
    Dim shtTabB As Worksheet
    Dim shtTabC As Worksheet
     
    Set shtTabA = Sheets("Tabela A")
    Set shtTabB = Sheets("Tabela B")
    Set shtTabC = Sheets("Tabela C")
      
    'Copiando e colando de A para C
    shtTabA.Activate
    ULin = Range("A1048576").End(xlUp).Row
    Rows(ULin).Select
    Selection.Copy
   
    shtTabC.Activate
    ULin = Range("A1048576").End(xlUp).Row
    Rows(ULin + 1).PasteSpecial Paste:=xlPasteValues
    Rows(ULin + 1).PasteSpecial Paste:=xlPasteFormats
   
    'Copiando e colando de B para C
    shtTabB.Activate
    ULin = Range("A1048576").End(xlUp).Row
    Rows(ULin).Select
    Selection.Copy
  
    shtTabC.Activate
    ULin = Range("A1048576").End(xlUp).Row
    Rows(ULin + 1).PasteSpecial Paste:=xlPasteValues
    Rows(ULin + 1).PasteSpecial Paste:=xlPasteFormats
   
    Application.CutCopyMode = False
    Range("A1").Select  
End Sub
_______________________________________
Sub Trans_Dados02()
    Dim ULin As Integer
    Dim shtTabA As Worksheet
    Dim shtTabB As Worksheet
    Dim shtTabC As Worksheet
     
    Set shtTabA = Sheets("Tabela A")
    Set shtTabB = Sheets("Tabela B")
    Set shtTabC = Sheets("Tabela C")
      
    'Copiando e colando de A para C
    shtTabA.Activate
    ULin = Range("A1048576").End(xlUp).Row
   
    LinC = 6
    Do While LinC < 2001
        If shtTabA.Cells(ULin, 1).Value = shtTabC.Cells(LinC, 1).Value Then
             MsgBox "O ultimo dado da tabela A já existe em C. Clique em OK para continuar!"
             Range("A1").Select
             GoTo PularParaB
        End If
       LinC = LinC + 1
    Loop
      
    Rows(ULin).Select
    Selection.Copy
    Range("A1").Select
   
    shtTabC.Activate
    ULin = Range("A1048576").End(xlUp).Row
    Rows(ULin + 1).PasteSpecial Paste:=xlPasteValues
    Rows(ULin + 1).PasteSpecial Paste:=xlPasteFormats
   
    'Copiando e colando de B para C
PularParaB:
    shtTabB.Activate
    ULin = Range("A1048576").End(xlUp).Row
   
    LinC = 6
    Do While LinC < 2001
       If shtTabB.Cells(ULin, 1).Value = shtTabC.Cells(LinC, 1).Value Then
           MsgBox "O ultimo dado da tabela B já existe em C. Clique em OK para continuar!"
           Range("A1").Select
           GoTo PularParaFim
       End If
       LinC = LinC + 1
    Loop
   
    Rows(ULin).Select
    Selection.Copy
    Range("A1").Select
  
    shtTabC.Activate
    ULin = Range("A1048576").End(xlUp).Row
    Rows(ULin + 1).PasteSpecial Paste:=xlPasteValues
    Rows(ULin + 1).PasteSpecial Paste:=xlPasteFormats
   
PularParaFim:
    Application.CutCopyMode = False
    shtTabC.Activate
    Range("A1").Select  
End Sub


9 - Como gerar números aleatórios no VBA?

CÓDIGOS:
Sub Aleatório1()   
      ActiveSheet.Range("D9").Value = Int((100 * Rnd) + 1)
End Sub
_______________________________________
Sub Aleatório2()
      Dim N As Integer
      N = Range("I9").Value   
      ActiveSheet.Range("K8").Value = Int((N * Rnd) + 1)
End Sub
_______________________________________ 
Sub Aleatório3()
    Dim N, N01, N02, N03, N04, N05 As Integer
    N = 10       
    ActiveSheet.Range("Q09").Value = Int((N * Rnd) + 1)
    ActiveSheet.Range("Q10").Value = Int((N * Rnd) + 1)
Subir1:
    N01 = Range("Q09").Value
    N02 = Range("Q10").Value
    If N02 = N01 Then
       ActiveSheet.Range("Q10").Value = Int((N * Rnd) + 1)
         If N01 = N02 Then
            GoTo Subir1
         End If
    End If
   
    ActiveSheet.Range("Q11").Value = Int((N * Rnd) + 1)
Subir2:
    N03 = Range("Q11").Value
    If (N03 = N01 Or N03 = N02) Then
       ActiveSheet.Range("Q11").Value = Int((N * Rnd) + 1)
         If (N03 = N01 Or N03 = N02) Then
            GoTo Subir2
         End If
    End If

ActiveSheet.Range("Q12").Value = Int((N * Rnd) + 1)
Subir3:
    N04 = Range("Q12").Value
    If (N04 = N01 Or N04 = N02 Or N04 = N03) Then
       ActiveSheet.Range("Q12").Value = Int((N * Rnd) + 1)
         If (N04 = N01 Or N04 = N02 Or N04 = N03) Then
            GoTo Subir3
         End If
    End If
   
    ActiveSheet.Range("Q13").Value = Int((N * Rnd) + 1)
Subir4:
    N05 = Range("Q13").Value
    If (N05 = N01 Or N05 = N02 Or N05 = N03 Or N05 = N04) Then
       ActiveSheet.Range("Q13").Value = Int((N * Rnd) + 1)
         If (N05 = N01 Or N05 = N02 Or N05 = N03 Or N05 = N04) Then
            GoTo Subir4
         End If
    End If
End Sub


10 - è possível associar uma barra de rolagem a um comboBox?


CÓDIGOS:
Private Sub Worksheet_Change(ByVal Target As Range)
      If Target.Address = "$F$2" Then
          Range("A1").Value = Range("F2").Value
      End If
End Sub
_______________________________________
Private Sub Combo_01_Change()
      Range("A1").Value = Combo_01
End Sub

























Comentários

Postar um comentário