Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Dificuldades em cor...
 
Notifications
Clear all

Dificuldades em cortar mais de uma linha

 
2024 - VBA & Macros
Post Recente por rlsobrinho 7 anos atrás
5 Posts
4 Usuários
0 Reactions
807 Visualizações
RSS
 rlsobrinho
(@rlsobrinho)
Posts: 2
New Member
Topic starter
 

Pessoal, muito bom dia,

Estou com dificuldades nesse código abaixo. Quando eu executo ele, ele recorta a linha que tiver CLIENTE na coluna Q certinho, porém se tiver duas linhas com CLIENTE aparece apenas a ultima linha na planilha prospects.

Tentei por um for antes do For i = 0 To UBound(aTokens) de 0 para o numero de ocorrencias da palabra cliente, porém também não funcionou.

Sub EfetivarProspects()
Dim i As Integer, LinhaEscrever As Integer
Dim aTokens() As String: aTokens = Split("CLIENTE", ",")
Dim TotalLinhas As Integer
Dim rDate As Date
LinhaEscrever = 5

Sheets("CLIENTES").Select
TotalLinhas = (Cells(Rows.Count, 1).End(xlUp).Row)
Sheets("PROSPECTS").Select

For Each cell In Sheets("PROSPECTS").Range("Q6:Q999")
        If (Len(cell.Value) <> 0) Then
            LinhaEscrever = (TotalLinhas + 1)
                 For i = 0 To UBound(aTokens)
                    If InStr(1, cell.Value, aTokens(i), vbTextCompare) Then
                         Sheets("PROSPECTS").Rows(cell.Row).Cut Sheets("CLIENTES").Rows(LinhaEscrever)
                         Sheets("CLIENTES").Range("R" & LinhaEscrever).Value = (Date)
                    End If
                    Next
         Else
         Exit For
         End If
Next

Dim myRange As Range
On Error Resume Next
Set myRange = Range("A6:A999")
myRange.SpecialCells(xlBlanks).EntireRow.delete
End Sub

Aguardo ajuda.

Muito obrigado

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

https://www.youtube.com/results?search_query=vba+recortar+e+colar

 
Postado : 07/03/2018 8:22 am
Wagner Morel
 Wagner Morel
(@wagner-morel-vidal-nobre)
Posts: 0
Illustrious Member
 

rlsobrinho,

Boa tarde!

Seja muito bem vindo ao fórum.

Para aproveitar ao máximo o fórum e sempre manter o mesmo de forma organizada, sugiro ler os tópico da regras abaixo:
viewtopic.php?f=7&t=16757
viewtopic.php?f=7&t=203
viewtopic.php?f=7&t=7903
viewtopic.php?f=7&t=3841
viewtopic.php?f=7&t=12600
viewtopic.php?f=7&t=3371

Quanto a sua dúvida, a maneira mais rápida de ser ajudado por todos é anexando, aqui mesmo no fórum, seu arquivo compactado com .ZIP.

Desenvolvo pequenas soluções em VBA Excel a valores que variam entre R$ 50,00 a R$ 200,00. Se te interessar, entre no meu instagran (vba_excel_desenvolvimento)

Atenciosamente
Wagner Morel

 
Postado : 07/03/2018 12:15 pm
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

O ideal era ter um modelo, mas veja se é isto :

Sub EfetivarProspects()
Dim i As Integer, LinhaEscrever As Integer
Dim aTokens() As String: aTokens = Split("CLIENTE", ",")
Dim TotalLinhas As Integer
Dim rDate As Date

'não entendi o porque desta definição
''se usa a variavel TotalLinhas
'LinhaEscrever = 5

Sheets("CLIENTES").Select
'armazena a qde de linhas na coluna A da aba CLIENTES
TotalLinhas = (Cells(Rows.Count, 1).End(xlUp).Row)

Sheets("PROSPECTS").Select

For Each cell In Sheets("PROSPECTS").Range("Q6:Q17")
        
        If (Len(cell.Value) <> 0) Then
            LinhaEscrever = (TotalLinhas + 1)
                 
                 For i = 0 To UBound(aTokens)
                    If InStr(1, cell.Value, aTokens(i), vbTextCompare) Then
                         
                         Sheets("PROSPECTS").Rows(cell.Row).Cut Sheets("CLIENTES").Rows(LinhaEscrever)
                         Sheets("CLIENTES").Range("R" & LinhaEscrever).Value = (Date)
                         
                         'incrementamos a variavel novamente
                         TotalLinhas = TotalLinhas + 1
                         
                    End If
                    Next
         Else
         Exit For
         End If
Next

Dim myRange As Range
On Error Resume Next
Set myRange = Range("A6:A999")
myRange.SpecialCells(xlBlanks).EntireRow.Delete
End Sub

[]s

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 08/03/2018 6:16 am
 rlsobrinho
(@rlsobrinho)
Posts: 2
New Member
Topic starter
 

Pessoal muito obrigado a todos pela ajuda, mas o Mauro Coutinho matou o problema.

Sugiro ao pessoal da administração por algum sistema de doação no forum pois é muito eficiente!

 
Postado : 08/03/2018 6:38 am
Forum Jump:
  Tópico Anterior
Próximo Tópico