Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
editar todas a linh...
 
Notifications
Clear all

editar todas a linhas q conter os valores iguais

 
2024 - VBA & Macros
Post Recente por FAGNERIBAS 6 anos atrás
10 Posts
3 Usuários
0 Reactions
1,785 Visualizações
RSS
 FAGNERIBAS
(@fagneribas)
Posts: 67
Trusted Member
Topic starter
 

pessoal tenho esse codigo, ele funciona muito bem, so queria fazer uma alteraçao e nao consegui fazer q era alterar todas a linhas q tiver o mesmo valor, por exemplo pode existir mais de 5 linhas com o mesmo valor da busca q esta na coluna "A", sera q alguem poderia me ajudar a resolver esse problema?? 

Private Sub CommandButton5_Click()
' CARREGA DADOS DO LISTVIEW E FILTRA NA PLANILHA E ALTERA
On Error GoTo ERRO
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
 Application.DisplayAlerts = False
Application.EnableEvents = False

Dim resultado As VbMsgBoxResult
     resultado = MsgBox("TEM CERTEZA QUE DESEJA REALIZAR ESSA VENDA?", vbYesNo, "F R CONTROLES")
     If resultado = vbYes Then
  
  Dim i As Integer, j As Integer
'conta qunatas linhas tem na minha listview
For i = 1 To ListView1.ListItems.Count
'valor procurado no listview

Dim codigo As Variant
codigo = ListView1.ListItems.ITEM(i)

ListView1.ListItems(i).Text = Empty
'fecha a busca no listview e limpa as linhas
'busca os dados na planilha e altera

With Worksheets("ESTOQUE").Range("A:A")
Set c = .Find(codigo, LookIn:=xlValues, LookAt:=xlWhole)

If Not c Is Nothing Then

c.Activate
c.Select

'Rows(Selection).Interior.ColorIndex = 8
Selection.Columns(9) = ComboBox1.Value 'CLIENTE
Selection.Columns(11) = TextBox3.Value ' DATA

End If
End With

'fecha a busca na planilha e altera

For j = 1 To ListView1.ColumnHeaders.Count - 1

ListView1.ListItems(i).ListSubItems(j).Text = Empty

Next j

Next i


MsgBox "VENDA REALIZADA COM SUCESSO", vbInformation, "F R CONTROLES"

ListView1.ListItems.Clear
Label9 = ""
Label7 = ""

Else

MsgBox "CANCELADO COM SUCESSO", vbInformation, "F R CONTROLES"
Exit Sub
End If
' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic


Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM AO REALIZAR A VENDA", vbInformation, "F R CONTROLES"

End Sub
 
Postado : 02/07/2018 3:21 pm
 klarc28
(@klarc28)
Posts: 971
Prominent Member
 
Private Sub CommandButton5_Click()
' CARREGA DADOS DO LISTVIEW E FILTRA NA PLANILHA E ALTERA
On Error GoTo ERRO
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

Dim resultado As VbMsgBoxResult
     resultado = MsgBox("TEM CERTEZA QUE DESEJA REALIZAR ESSA VENDA?", vbYesNo, "F R CONTROLES")
     If resultado = vbYes Then
  
  Dim i As Integer, j As Integer
'conta qunatas linhas tem na minha listview
For i = 1 To ListView1.ListItems.Count
'valor procurado no listview

Dim codigo As Variant
codigo = ListView1.ListItems.ITEM(i)

ListView1.ListItems(i).Text = Empty
'fecha a busca no listview e limpa as linhas
'busca os dados na planilha e altera

dim novalinha as long

novalinha = 1

while Worksheets("ESTOQUE").Range("A" & novalinha).value <> ""

'With Worksheets("ESTOQUE").Range("A:A")
'Set c = .Find(codigo, LookIn:=xlValues, LookAt:=xlWhole)

'If Not c Is Nothing Then
if Worksheets("ESTOQUE").Range("A" & novalinha).value = codigo then
''c.Activate
'c.Select
Worksheets("ESTOQUE").Range("A" & novalinha).select
'Rows(Selection).Interior.ColorIndex = 8
Selection.Columns(9) = ComboBox1.Value 'CLIENTE
Selection.Columns(11) = TextBox3.Value ' DATA

'End If
'End With
end if
novalinha = novalinha+1
wend

'fecha a busca na planilha e altera

For j = 1 To ListView1.ColumnHeaders.Count - 1

ListView1.ListItems(i).ListSubItems(j).Text = Empty

Next j

Next i


MsgBox "VENDA REALIZADA COM SUCESSO", vbInformation, "F R CONTROLES"

ListView1.ListItems.Clear
Label9 = ""
Label7 = ""

Else

MsgBox "CANCELADO COM SUCESSO", vbInformation, "F R CONTROLES"
Exit Sub
End If
' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic

Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM AO REALIZAR A VENDA", vbInformation, "F R CONTROLES"

End Sub

outra forma

dim novalinha as long
for novalinha = 1 to Worksheets("ESTOQUE").usedRange.rows.count

'while Worksheets("ESTOQUE").Range("A" & novalinha).value <> ""

'With Worksheets("ESTOQUE").Range("A:A")
'Set c = .Find(codigo, LookIn:=xlValues, LookAt:=xlWhole)

'If Not c Is Nothing Then
if Worksheets("ESTOQUE").Range("A" & novalinha).value = codigo then
''c.Activate
'c.Select
Worksheets("ESTOQUE").Range("A" & novalinha).select
'Rows(Selection).Interior.ColorIndex = 8
Selection.Columns(9) = ComboBox1.Value 'CLIENTE
Selection.Columns(11) = TextBox3.Value ' DATA

'End If
'End With
end if
'novalinha = novalinha+1
'wend
next novalinha
 
Postado : 02/07/2018 3:34 pm
 FAGNERIBAS
(@fagneribas)
Posts: 67
Trusted Member
Topic starter
 

klarc28
AMIGO O CODIGO PARECE SER OTIMO, POREM ELE NAO ESTA ALTERANDO NA PLANILHA AS LINHAS Q TEM O CODIGO, E EU NAO ENTENDO MUITO BEM VBA, SERA Q PODE ME AJUDAR NESSE SEU CODIGO. DESDE JA AGRADEÇO A SUA ATENÇÃO, MUITO OBG

 
Postado : 03/07/2018 5:42 am
 klarc28
(@klarc28)
Posts: 971
Prominent Member
 

Algumas regras do fórum:

Não escreva com letras maiúsculas.
Não faça citações desnecessárias.

Regra da língua portuguesa:

Use ponto de interrogação quando fizer uma pergunta:

"Pode me ajudar no seu código?"

 
Postado : 03/07/2018 6:17 am
 klarc28
(@klarc28)
Posts: 971
Prominent Member
 

Explicando o erro.

Você declarou o código como Variant.
Então ele estava considerando o código como uma String.
Por exemplo:
O código 29, ele estava considerando como "29".

Aí ele comparava:

29 da planilha é igual a "29" da listview?

Não. Então não entrava naquele trecho de código.

Declarei o código como Double, pois se trata de um número.

Também poderia ser Integer ou Long.

Usei Cdbl para converter o dado da planilha para Double, só para garantir que eu estava lidando com um dado do tipo Double.

Se o dado fosse Integer, seria Cint.
Se o dado fosse Long, seria Clng.

Private Sub ListView1_DblClick()
On Error GoTo ERRO
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
 Application.DisplayAlerts = False
Application.EnableEvents = False


Dim resultado As VbMsgBoxResult
     resultado = MsgBox("DESEJA REALMENTE EXCLUIR?", vbYesNo, "F R CONTROLES")
     If resultado = vbYes Then
          Dim ITEM As Long
With ListView1

ITEM = .SelectedItem.Index
.ListItems.Remove (ITEM)
MsgBox "EXCLUIDO COM SUSSECO", vbInformation, "F R CONTROLES"

Call SOMAR
Call contar
End With
     Else
         MsgBox "CANCELADO", vbInformation, "F R CONTROLES"
     End If

' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic


Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM ERRO AO EXCLUIR ", vbInformation, "F R CONTROLES"


End Sub


Private Sub ComboBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'KeyAscii = 0
End Sub
Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    ' FAZ PULAR COM O ENTER OU TAB
    If KeyCode = 13 Then
        SendKeys "{TAB}"
    End If
End Sub


Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)

If Len(ComboBox1.Text) < "1" Then



ComboBox1.SelStart = 4

ComboBox1.SelLength = ComboBox1.TextLength

Else: End If
End Sub


Private Sub CommandButton1_CLICK()
On Error GoTo ERRO
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
 Application.DisplayAlerts = False
Application.EnableEvents = False


'NAO DEIXA CAMPOS VAZIOS
If TextBox1.Value = "" Or ComboBox1.Value = "" Or TextBox3.Value = "" Then

MsgBox "TODOS OS CAMPOS DEVEM SER PREENCHIDOS", vbInformation, "F R CONTROLES"

Exit Sub

End If
    
    
    
    
    
    Dim vcodigo As String
    Dim i As Long
    Dim UltimaLinha As Long
    
    Sheets("ESTOQUE").Select
    ActiveSheet.Range("A2").Select
    UltimaLinha = Sheets("ESTOQUE").Cells(Cells.Rows.Count, 1).End(xlUp).Row
    If UltimaLinha < 2 Then UltimaLinha = 2
    
    'ListView1.ListItems.Clear
    vcodigo = TextBox1
    
    lin = 2
    
    For i = 2 To UltimaLinha
    'Do While ActiveCell <> ""
       'If ActiveCell.Value = vcodigo Then
        If Range("A" & i).Value = vcodigo Then
        
            Set Linha = ListView1.ListItems.Add(Text:=Sheets("ESTOQUE").Range("A" & i).Value) ' PLAQUETA
            Linha.ListSubItems.Add Text:=TextBox3.Value ' DATA
            Linha.ListSubItems.Add Text:=Sheets("ESTOQUE").Range("C" & i).Value ' ESPECIE
            Linha.ListSubItems.Add Text:=Format(Sheets("ESTOQUE").Range("D" & i).Value, "0.00") ' COMPRIMENTO
            Linha.ListSubItems.Add Text:=Format(Sheets("ESTOQUE").Range("E" & i).Value, "0.0") ' LARGURA
            Linha.ListSubItems.Add Text:=Format(Sheets("ESTOQUE").Range("F" & i).Value, "0.0") ' ESPESSURA
            Linha.ListSubItems.Add Text:=Format(Sheets("ESTOQUE").Range("G" & i).Value, "0") ' PEÇAS
            Linha.ListSubItems.Add Text:=Format(Sheets("ESTOQUE").Range("H" & i).Value, "0.000") ' TOTAL PEÇAS
            Linha.ListSubItems.Add Text:=ComboBox1.Value ' CLIENTE
            Linha.ListSubItems.Add Text:=Format(Sheets("ESTOQUE").Range("J" & i).Value, "0,000") ' CLASSIFICAÇÃO
            'Exit Do
            
        
       
     
     ActiveCell.Offset(1, 0).Select
    
    End If
   ' Loop
    
   Next
 
 For H = 1 To ListView1.ListItems.Count

If ListView1.ListItems.ITEM(H).ListSubItems(6).Text >= 0 Then
    ListView1.ListItems.ITEM(H).ListSubItems(6).ForeColor = RGB(0, 255, 255)
End If

Next H

For j = 1 To ListView1.ListItems.Count

If ListView1.ListItems.ITEM(j).ListSubItems(8).Text > "1" Then
    ListView1.ListItems.ITEM(j).ListSubItems(8).ForeColor = RGB(0, 0, 255)

End If

Next j

For G = 1 To ListView1.ListItems.Count

If ListView1.ListItems.ITEM(G).ListSubItems(7).Text >= 0 Then
    ListView1.ListItems.ITEM(G).ListSubItems(7).ForeColor = RGB(255, 102, 51)

End If

Next G
Call contar
Call SOMAR

CommandButton3.Visible = True
CommandButton4.Visible = True
CommandButton5.Visible = True
TextBox1 = ""
TextBox1.SetFocus


' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic


Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM ERRO", vbInformation, "F R CONTROLES"
End Sub

Sub Retira_Repetidos()
 On Error GoTo ERRO
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
 Application.DisplayAlerts = False
Application.EnableEvents = False

 ' -- Variables
    Dim i       As Long
    Dim j       As Long
    Dim ret     As Long             ' -- total de items que se eliminan
      
    With ListView
        ' -- Recorrer todos los items
        For i = 1 To Me.ListView1.ListItems.Count
            ' -- Comparar uno a uno con todos los demás
            For j = i + 1 To Me.ListView1.ListItems.Count
                If Me.ListView1.ListItems.ITEM(i) = Me.ListView1.ListItems.ITEM(j) Then
                    ' -- Si es igual eliminar
                    Me.ListView1.ListItems.Remove Me.ListView1.ListItems.ITEM(j).Index
                    j = j - 1
                    ret = ret + 1
                MsgBox "ATENÇÃO PLAQUETA JA ADICIONADA", vbInformation, "F R CONTROLES"
                TextBox1 = ""
                TextBox1.SetFocus
                End If
                If j = Me.ListView1.ListItems.Count Then
                    Exit For
                End If
            Next
              
            If i = Me.ListView1.ListItems.Count Then
                ' -- Retorna el valor de la función con _
                la cantidad de elementos eliminados
                Eliminar_Item_ListView = ret
                
            End If
        Next
    End With

' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic


Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM ERRO", vbInformation, "F R CONTROLES"
  
End Sub


Private Sub CommandButton2_Click()
Unload Me

End Sub
Sub Contar_Registros2()
On Error GoTo ERRO
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
 Application.DisplayAlerts = False
Application.EnableEvents = False



    Dim numeroRegistros As Integer

    Dim i As Integer

    For i = 4 To Planilha7.Cells(Rows.Count, "a").End(xlUp).Row

        

              numeroRegistros = numeroRegistros + 1

      

    Next i

[A1048576].End(xlUp).Offset(2, 0).Font.Bold = True
[A1048576].End(xlUp).Offset(2, 0).Font.ColorIndex = 3
[A1048576].End(xlUp).Offset(2, 0).Value = "               QNT DE TORAS"

[C1048576].End(xlUp).Offset(2, 0).Font.Bold = True
[C1048576].End(xlUp).Offset(2, 0).Font.ColorIndex = 3
[C1048576].End(xlUp).Offset(2, 0).Value = numeroRegistros


' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic


Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM ERRO", vbInformation, "F R CONTROLES"

End Sub
Sub SOMASES()

On Error GoTo ERRO
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
 Application.DisplayAlerts = False
Application.EnableEvents = False



Dim ULTIMACELULA As Range
' COMERCIAL
Planilha7.Select

Planilha7.Range("O6").Select

Set ULTIMACELULA = Planilha7.Range("N1048576").End(xlUp)


Do While ActiveCell.Row <= ULTIMACELULA.Row

ActiveCell.Value = WorksheetFunction.SumIfs(Planilha7.Range("L4:L1048576"), Planilha7.Range("G4:G1048576"), Planilha7.Range("N" & ActiveCell.Row).Text)

ActiveCell.Offset(1, 0).Select

Loop


' IBAMA
Planilha7.Select

Planilha7.Range("P6").Select

Set ULTIMACELULA = Planilha7.Range("N1048576").End(xlUp)


Do While ActiveCell.Row <= ULTIMACELULA.Row


ActiveCell.Value = WorksheetFunction.SumIfs(Planilha7.Range("M4:M1048576"), Planilha7.Range("G4:G1048576"), Planilha7.Range("N" & ActiveCell.Row).Text)
ActiveCell.Offset(1, 0).Select

Loop

' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic


Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM ERRO", vbInformation, "F R CONTROLES"
End Sub
Sub COMERCIAL()
On Error GoTo ERRO
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
 Application.DisplayAlerts = False
Application.EnableEvents = False

'SOMA O TOTAL DE COMERCIAL SO SOMASE
Dim contador As Long
Dim TOTAL As Currency

For contador = 4 To Planilha3.Cells(Rows.Count, "K").End(xlUp).Row

TOTAL = TOTAL + Planilha3.Cells(contador, "K")

Next contador


[O1048576].End(xlUp).Offset(2, 0).Font.Bold = True
[O1048576].End(xlUp).Offset(2, 0).Font.ColorIndex = 3
[O1048576].End(xlUp).Offset(2, 0).Value = CDbl(Format(TOTAL, "0.000"))
 
 
' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic


Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM ERRO FAZER O CALCULO", vbInformation, "F R CONTROLES"

End Sub
Sub IMPRIMIR()


On Error GoTo ERRO
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
 Application.DisplayAlerts = False
Application.EnableEvents = False
Call TIRAR_FORMATAÇAO

' PUXA DADOS DO LISTVIEW 1 PARA ABA IMPRIMIR
Sheets("IMPRESSÃO").Range("A2:R50000").ClearContents
Planilha3.Select

Dim inicio As Range
 
Set inicio = Planilha3.Range("A1")

With Planilha3

For i = 1 To ListView1.ListItems.Count

inicio.Cells(i + 1, 1) = ListView1.ListItems(i).Text ' PACOTE
inicio.Cells(i + 1, 2) = CDate(ListView1.ListItems(i).SubItems(1)) 'DATA
inicio.Cells(i + 1, 3) = (ListView1.ListItems(i).SubItems(2)) ' ESPECIE
inicio.Cells(i + 1, 4) = CDbl(ListView1.ListItems(i).SubItems(3)) ' COMPRIMENTO
inicio.Cells(i + 1, 5) = CDbl(ListView1.ListItems(i).SubItems(4)) ' LARGURA
inicio.Cells(i + 1, 6) = CDbl(ListView1.ListItems(i).SubItems(5)) ' ESPESSURA
inicio.Cells(i + 1, 7) = CDbl((ListView1.ListItems(i).SubItems(6))) ' PEÇAS
inicio.Cells(i + 1, 8) = CDbl(ListView1.ListItems(i).SubItems(7)) ' TOTAL M ³
inicio.Cells(i + 1, 9) = ListView1.ListItems(i).SubItems(8) ' SITUAÇÃO
inicio.Cells(i + 1, 10) = ListView1.ListItems(i).SubItems(9) ' CLASSIFICAÇÃO


Next
End With

            

Dim contador As Long
Dim TOTAL As Currency

For contador = 2 To Planilha3.Cells(Rows.Count, "H").End(xlUp).Row

TOTAL = TOTAL + Planilha3.Cells(contador, "H")

Next contador


[G1048576].End(xlUp).Offset(2, 1).Font.Bold = True
[G1048576].End(xlUp).Offset(2, 1).Font.ColorIndex = 3
[G1048576].End(xlUp).Offset(2, 1).Value = CDbl(Format(TOTAL, "0.000"))


[G1048576].End(xlUp).Offset(2, 0).Font.Bold = True
[G1048576].End(xlUp).Offset(2, 0).Font.ColorIndex = 3
[G1048576].End(xlUp).Offset(2, 0).Value = "TOTAL M ³"




' FAZ FILTRO POR ESPECIE
'Sheets("IMPRESSÃO").Range("K4:L50000").ClearContents
'Sheets("IMPRESSÃO").Select
'Application.CutCopyMode = False
'    Application.CutCopyMode = False
'    Range("C1:C1048576").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
 '       "K3"), Unique:=True


Call ORGANIZA
Call PDF
'Call SOMASES

'CommandButton4.Visible = False
'CommandButton5.Visible = False
' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic


Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM ERRO NA HORA PREPARAR A IMPRESSÃO", vbInformation, "F R CONTROLES"
End Sub

Private Sub CommandButton3_Click()
Call TIRAR_FORMATAÇAO
Call IMPRIMIR
Call Set_Print_Area3
End Sub



Private Sub CommandButton4_Click()


Call IMPRIMIR


End Sub

Private Sub CommandButton5_Click()
' CARREGA DADOS DO LISTVIEW E FILTRA NA PLANILHA E ALTERA
On Error GoTo ERRO
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
 Application.DisplayAlerts = False
Application.EnableEvents = False

Dim resultado As VbMsgBoxResult
     resultado = MsgBox("TEM CERTEZA QUE DESEJA REALIZAR ESSA VENDA?", vbYesNo, "F R CONTROLES")
     If resultado = vbYes Then
  
  Dim i As Integer, j As Integer
'conta qunatas linhas tem na minha listview
For i = 1 To ListView1.ListItems.Count
'valor procurado no listview

Dim codigo As Double
codigo = CDbl(ListView1.ListItems.ITEM(i))

ListView1.ListItems(i).Text = Empty
'fecha a busca no listview e limpa as linhas
'busca os dados na planilha e altera

Dim novalinha As Long
For novalinha = 2 To Worksheets("ESTOQUE").UsedRange.Rows.Count

'while Worksheets("ESTOQUE").Range("A" & novalinha).value <> ""

'With Worksheets("ESTOQUE").Range("A:A")
'Set c = .Find(codigo, LookIn:=xlValues, LookAt:=xlWhole)

'If Not c Is Nothing Then
If CDbl(Worksheets("ESTOQUE").Range("A" & novalinha).Value) = codigo Then
''c.Activate
'c.Select
Worksheets("ESTOQUE").Range("A" & novalinha).Select
Rows(Selection.Row).Interior.ColorIndex = 8
Selection.Columns(9) = ComboBox1.Value 'CLIENTE
Selection.Columns(11) = TextBox3.Value ' DATA

'End If
'End With
End If
'novalinha = novalinha+1
'wend
Next novalinha

'fecha a busca na planilha e altera

For j = 1 To ListView1.ColumnHeaders.Count - 1

ListView1.ListItems(i).ListSubItems(j).Text = Empty

Next j

Next i


MsgBox "VENDA REALIZADA COM SUCESSO", vbInformation, "F R CONTROLES"

ListView1.ListItems.Clear
Label9 = ""
Label7 = ""

Else

MsgBox "CANCELADO COM SUCESSO", vbInformation, "F R CONTROLES"
Exit Sub
End If
' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic


Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM AO REALIZAR A VENDA", vbInformation, "F R CONTROLES"

End Sub




Private Sub Label13_Click()

End Sub

Private Sub TextBox1_Change()
If Not IsNumeric(TextBox1) Then TextBox1 = Empty

End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

End Sub

Private Sub TextBox3_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
On Error GoTo ERRO
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
 Application.DisplayAlerts = False
Application.EnableEvents = False

TextBox3.MaxLength = 10 '10/10/2014
 Select Case KeyAscii
      Case 8       'Aceita o BACK SPACE
      Case 13: SendKeys "{TAB}"    'Emula o TAB
      Case 48 To 57
         If TextBox3.SelStart = 2 Then TextBox3.SelText = "/"
         If TextBox3.SelStart = 5 Then TextBox3.SelText = "/"
      Case Else: KeyAscii = 0     'Ignora os outros caracteres
   
   
   End Select




' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic


Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM ERRO NA DATA", vbInformation, "F R CONTROLES"
End Sub
Private Sub TextBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean)
On Error GoTo ERRO
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
 Application.DisplayAlerts = False
Application.EnableEvents = False

If Len(TextBox3.Text) < 10 Then



Cancel = True

TextBox3.SelStart = 0

TextBox3.SelLength = TextBox3.TextLength

Else: End If


' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic


Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM ERRO NA DATA", vbInformation, "F R CONTROLES"


End Sub





Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
On Error GoTo ERRO
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
 Application.DisplayAlerts = False
Application.EnableEvents = False


Planilha1.Activate
Planilha1.Select

Resp = TextBox1.Value


With Worksheets("ESTOQUE").Range("A:A")
  Set c = .Find(Resp, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
 c.Activate
TextBox1.Value = c.Value
'cod = PLAQUETA


Else

MsgBox " PACOTE NAO ENCONTRADA", vbInformation, "F R CONTROLES"
TextBox1 = ""
TextBox1.SetFocus

Exit Sub



End If
  End With






' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic


Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM ERRO", vbInformation, "F R CONTROLES"




End Sub
Sub Set_Print_Area3()
On Error GoTo ERRO
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
 Application.DisplayAlerts = False
Application.EnableEvents = False

'MOSTRA PAGINA Q IRA SER IMPRIMIDA
 VENDAS.Hide
Dim x As Long, lastCell As Range, LR As Long
x = ActiveSheet.UsedRange.Columns.Count
Set lastCell = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0)
LR = lastCell.Row
Do Until Application.Count(Range(Cells(LR, 2), Cells(LR, 256))) <> 0
Set lastCell = lastCell.Offset(-1, 0)
LR = lastCell.Row
Loop
ActiveSheet.PageSetup.PrintArea = Range(Cells(1, 1), lastCell).Address
Application.Dialogs(xlDialogPrintPreview).Show
VENDAS.Show

' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic


Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM ERRO", vbInformation, "F R CONTROLES"
End Sub
Private Sub UserForm_QueryClose _
  (Cancel As Integer, CloseMode As Integer)
    
  ' NAO DEIXA FECHAR NO "X" AS ABAS DO PROGRAMA
  '  If CloseMode = vbFormControlMenu Then
   '     MsgBox "PORFAVOR CANÇELAR ", vbInformation, "F R CONTROLES"
  '      Cancel = True
 '   End If
End Sub
Private Sub UserForm_Initialize()
On Error GoTo ERRO
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
 Application.DisplayAlerts = False
Application.EnableEvents = False
CommandButton3.Visible = False
CommandButton4.Visible = False
CommandButton5.Visible = False
With ListView1
        .Gridlines = True
        .View = lvwReport
        .FullRowSelect = True
        .ColumnHeaders.Add Text:="PACOTE", Width:=55, Alignment:=0
.ColumnHeaders.Add Text:="DATA VENDA", Width:=65, Alignment:=2
.ColumnHeaders.Add Text:="ESPÉCIE", Width:=137, Alignment:=2
.ColumnHeaders.Add Text:="COMP.", Width:=65, Alignment:=2
.ColumnHeaders.Add Text:="LARGURA", Width:=65, Alignment:=2
.ColumnHeaders.Add Text:="ESPESSURA", Width:=65, Alignment:=2
.ColumnHeaders.Add Text:="QTD PEÇAS", Width:=65, Alignment:=2
.ColumnHeaders.Add Text:="TOTAL M ³", Width:=65, Alignment:=2
.ColumnHeaders.Add Text:="CLIENTE", Width:=80, Alignment:=2
.ColumnHeaders.Add Text:="CL", Width:=50, Alignment:=2
       
       End With



'CLIENTE
Linha = 2


         Do Until Sheets("CLIENTES").Cells(Linha, 1) = ""
        
        
        
         ComboBox1.AddItem Sheets("CLIENTES").Cells(Linha, 1)
        
        
        
          Linha = Linha + 1



Loop



Dim ini, fim As Integer
Dim i, j As Integer
Dim menor As String
ini = 0
fim = ComboBox1.ListCount - 1 '4 itens(0 - 3)
For i = ini To fim - 1 'Comparar 1 item com outros 3
    For j = i + 1 To fim 'Comparar com o próximo
        If ComboBox1.List(i) > ComboBox1.List(j) Then
            menor = ComboBox1.List(j)
            ComboBox1.List(j) = ComboBox1.List(i)
           ComboBox1.List(i) = menor
        End If
    Next j
Next i


' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic


Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM ERRO", vbInformation, "F R CONTROLES"
Label13.Visible = False
CommandButton5.Visible = False
CommandButton4.Visible = False

End Sub


Sub contar()
On Error GoTo ERRO
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
 Application.DisplayAlerts = False
Application.EnableEvents = False

' conta a quantidade de linhas preenchidas
Dim linhas As Integer
Dim soma As Double

With VENDAS

linhas = .ListView1.ListItems.Count
For i = 1 To linhas
soma = soma + .ListView1.ListItems(i).ListSubItems(6)
Next
.Label9.Caption = Format(soma, "0")

End With




' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic


Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM ERRO AO CONTAR A QUANTIDADE DE PEÇAS", vbInformation, "F R CONTROLES"

End Sub
Sub SOMAR()
On Error GoTo ERRO
' DESABILITA CALCULOS AUTOMATICOS
Application.Calculation = xlManual
' DESABILITA EVENTOS DA TELA
Application.ScreenUpdating = False
 Application.DisplayAlerts = False
Application.EnableEvents = False


' SOMA O TOTAL DE M3
Dim linhas As Integer
Dim soma As Double

With VENDAS

linhas = .ListView1.ListItems.Count
For i = 1 To linhas
soma = soma + .ListView1.ListItems(i).ListSubItems(7)
Next
.Label7.Caption = Format(soma, "0.000")

End With
' HABILITA A TELA
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

'HABILITA CACULOS
Application.Calculation = xlAutomatic

Exit Sub
ERRO:
MsgBox "ACONTECEU ALGUM ERRO AO SOMAR", vbInformation, "F R CONTROLES"
End Sub
 
Postado : 03/07/2018 8:48 am
 FAGNERIBAS
(@fagneribas)
Posts: 67
Trusted Member
Topic starter
 

klarc28
valeu meu amigo funcionou perfeitamente, muito obrigado
sera q posso ti incomodar so mais um pouco, tipo eu queria q ele so buscase as linhas q estao sem colorir, e quando tiver cor ele ivitase, tipo uma buscar por cor isso e possivel?

 
Postado : 03/07/2018 1:37 pm
 MPrudencio
(@mprudencio)
Posts: 2749
Famed Member
 

... tipo eu queria q ele so buscase as linhas q estao sem colorir, e quando tiver cor ele ivitase, tipo uma buscar por cor isso e possivel?

Que criterio vc usa para colorir??

É so excluir este criterio no codigo.

Marcelo Prudencio
Microsoft Excel Brasil no Facebook

"Começar já é a metade do caminho."
Autor Desconhecido

Simplifica que simples fica.
Nicole Tomazella.

"O Simples é Sempre Melhor Que o Complicado"
Jorge Paulo Lemann.

 
Postado : 03/07/2018 2:42 pm
 FAGNERIBAS
(@fagneribas)
Posts: 67
Trusted Member
Topic starter
 

MPrudencio

nao amigo oq eu quero q ele busque somente a cor azul por exemplo, ou a branca, isso e possivel?

 
Postado : 03/07/2018 3:04 pm
 klarc28
(@klarc28)
Posts: 971
Prominent Member
 

Não tive tempo de ver onde você preenche essa busca, mas basta adicionar mais uma condição no trecho em que você preenche a busca. Algo parecido com isto:

if sheets("tal").range("A" & linha).interior.color = vbwhite then

'Preenche a busca


end if

Daqui para a frente, deixo com outro usuário. Não vou responder mais.

 
Postado : 03/07/2018 8:34 pm
 FAGNERIBAS
(@fagneribas)
Posts: 67
Trusted Member
Topic starter
 

klarc28"

Daqui para a frente, deixo com outro usuário. Não vou responder mais.

valeu amigo muito obg... deus te abençoe

 
Postado : 04/07/2018 5:12 am
Forum Jump:
  Tópico Anterior
Próximo Tópico