Fórum Excel Bácico, Avançado e Vba
Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.
Fórum Excel Bácico, Avançado e Vba

Este fórum é destina a usuário de Excel, que queiram compartilhar informações a básicas, avançadas e programação em VBA...
 
InícioInício  Últimas imagensÚltimas imagens  ProcurarProcurar  RegistarRegistar  Entrar  

 

 Recortar e colar ultimas linhas e colar nas primeiras.

Ir para baixo 
2 participantes
AutorMensagem
danilomello




Mensagens : 2
Data de inscrição : 18/12/2012

Recortar e colar ultimas linhas e colar nas primeiras. Empty
MensagemAssunto: Recortar e colar ultimas linhas e colar nas primeiras.   Recortar e colar ultimas linhas e colar nas primeiras. EmptyTer Dez 18, 2012 4:51 pm

Bom dia, pessoal!

Sou novo aqui no fórum, estou com uma dúvida e espero que possam me ajudar, ja procurei em outros topicos e não achei.
Espero poder ajuda-los também.

Bom, tenho um programinha em vba que traz informações de diversas planilhas e de um banco de dados e monta um relatório todo personalizado.
Como o layout exige agumas linhas em branco e cada relatório que é feito sai com uma quantidade de linhas estou com dificuldades.

Tenho que jogar o quadro de total e em uma determinada linha (45 ou 47) dependendo do relatorio. esse quadro tem 8 linhas. e nao estou conseguindo seleciona-las devido as celulas em branco e por causa que cada relatorio tem uma quantidade de linhas.

Alguem pode me ajuda?

Desde ja, agradeço!
Ir para o topo Ir para baixo
alexandrevba

alexandrevba


Mensagens : 1820
Data de inscrição : 13/07/2011
Localização : Serra - ES

Recortar e colar ultimas linhas e colar nas primeiras. Empty
MensagemAssunto: Re: Recortar e colar ultimas linhas e colar nas primeiras.   Recortar e colar ultimas linhas e colar nas primeiras. EmptyTer Dez 18, 2012 5:29 pm

Boa tarde!!

Eu acho que sua maior chance está em, disponibilizar seu arquivo modelo!

Att
Ir para o topo Ir para baixo
danilomello




Mensagens : 2
Data de inscrição : 18/12/2012

Recortar e colar ultimas linhas e colar nas primeiras. Empty
MensagemAssunto: Re: Recortar e colar ultimas linhas e colar nas primeiras.   Recortar e colar ultimas linhas e colar nas primeiras. EmptyTer Dez 18, 2012 6:52 pm

Bom, ai vai ...



Dim sheet As String

sheet = ActiveSheet.Name

If FiltraLoja(cbxLoja.Text, sheet) Then

Call ColaVendedor(SelecionaVendedor(), CInt(txLinha.Text), sheet)

Call Relatorio(CInt(txLinha.Text))

Call SomaLinha(CInt(txLinha.Text))

Call SomaTotal(CInt(txLinha.Text))

End If

MsgBox "OLÁ " & Environ("USERNAME") & " SUA PIZZA COM BORDA DE CATUPIRI ESTA PRONTA", vbInformation, "PIZZARIA"

End Sub

Private Sub cbxLoja_Change()

End Sub

Private Sub Frame1_Click()

End Sub

Private Sub Label1_Click()

End Sub

Private Sub UserForm_Activate()
Dim loja As String
Dim i As Integer
Dim f As Integer

f = Sheets("VENDEDOR").Cells(Rows.Count, 10).End(xlUp).Row

For i = 2 To f

loja = Sheets("VENDEDOR").Cells(i, 10)

cbxLoja.AddItem loja

Next i

End Sub

Private Function FiltraLoja(ByVal loja, ByVal sheet) As Boolean
On Error GoTo erro
Sheets("VENDEDOR").Select
ActiveSheet.PivotTables("Tabela dinâmica1").PivotFields("LOCAL").ClearAllFilters
ActiveSheet.PivotTables("Tabela dinâmica1").PivotFields("LOCAL").CurrentPage = loja
Sheets(sheet).Select
FiltraLoja = True
Exit Function
erro:
FiltraLoja = False

End Function

Private Function SelecionaVendedor() As Integer
Dim f As Integer

f = Sheets("VENDEDOR").Cells(Rows.Count, 1).End(xlUp).Row

For i = 4 To f
ReDim Preserve Vendedor(f, 5)
Vendedor(i - 4, 0) = Sheets("VENDEDOR").Cells(i, 1)
Vendedor(i - 4, 1) = Sheets("VENDEDOR").Cells(i, 2)
Vendedor(i - 4, 2) = Sheets("VENDEDOR").Cells(i, 3)
Vendedor(i - 4, 3) = Sheets("VENDEDOR").Cells(i, 4)
Vendedor(i - 4, 4) = Sheets("VENDEDOR").Cells(i, 5)
Vendedor(i - 4, 5) = Sheets("VENDEDOR").Cells(i, 6)
Next i

SelecionaVendedor = f

End Function

Private Sub ColaVendedor(ByVal f As Integer, ByVal l As Integer, ByVal sheet)

For i = 0 To f - 4

Sheets(sheet).Cells(l, 2) = Vendedor(i, 0)
Sheets(sheet).Cells(l, 3) = Vendedor(i, 1)
Sheets(sheet).Cells(l, 4) = Vendedor(i, 2)
Sheets(sheet).Cells(l, 5) = Vendedor(i, 3)
Sheets(sheet).Cells(l, 6) = Vendedor(i, 4)
Sheets(sheet).Cells(l, 7) = Vendedor(i, 5)

Call InserirLinha(CStr(l + 1))

l = l + 8

Call CopiaFormatCondicional(l)

Call FormatLinha(CStr(l))

Next i


End Sub

Private Sub InserirLinha(ByVal linha As String)

For Add = 1 To 7

Rows(linha & ":" & linha).Select
Selection.Insert
'Selection.FormatConditions.Delete

Select Case Add
Case 1
Cells(CInt(linha), Cool = "FAT PROD"
Case 2
Cells(CInt(linha), Cool = "MRG PROD"
Case 3
Cells(CInt(linha), Cool = "FAT SERV"
Case 4
Cells(CInt(linha), Cool = "EFIC SERV"
Case 5
Cells(CInt(linha), Cool = "FAT TOT"
Case 6
Cells(CInt(linha), Cool = "MRG TOT"
Case 7
Cells(CInt(linha), Cool = "PRODUTIV"
End Select

Call FormatLinha1(linha)

linha = CInt(linha) + 1

Next Add
End Sub

Private Sub CopiaFormatCondicional(ByVal l As Integer)
Dim A As String, B As String

A = CStr(l - Cool
B = CStr(l)

Range("C" & A & ":G" & A).Select
Selection.Copy
Range("C" & B).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

End Sub

Private Sub FormatLinha(ByVal l As String)

Range("C" & l & ":AU" & l).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With Selection.Borders(xlEdgeRight)
.LineStyle = xlDouble
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

Range("AW" & l & ":BH" & l).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlDouble
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With Selection.Borders(xlEdgeRight)
.LineStyle = xlDouble
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

End Sub

Private Sub FormatLinha1(ByVal l As String)

Range("C" & l & ":G" & l).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

Range("M" & l & ":AT" & l).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With Selection.Borders(xlEdgeRight)
.LineStyle = xlDouble
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

Range("AW" & l & ":BG" & l).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlDouble
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With Selection.Borders(xlEdgeRight)
.LineStyle = xlDouble
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

End Sub

Private Sub Relatorio(ByVal l As Integer)
Dim f As Integer
Dim nome As String

f = Cells(Rows.Count, Cool.End(xlUp).Row

For i = l To f Step 8
nome = Trim(Cells(i, 3))
If BASE_PDM(nome) Then
For X = 0 To 6
Cells((i + (X + 1)), 15) = REL(X, 0) 'JAN
Cells((i + (X + 1)), 18) = REL(X, 1) 'FEV
Cells((i + (X + 1)), 21) = REL(X, 2) 'MAR
Cells((i + (X + 1)), 24) = REL(X, 3) 'ABR
Cells((i + (X + 1)), 27) = REL(X, 4) 'MAI
Cells((i + (X + 1)), 31) = REL(X, 5) 'JUN
Cells((i + (X + 1)), 34) = REL(X, 6) 'JUL
Cells((i + (X + 1)), 37) = REL(X, 7) 'AGO
Cells((i + (X + 1)), 40) = REL(X, Cool 'SET
Cells((i + (X + 1)), 43) = REL(X, 9) 'OUT
Cells((i + (X + 1)), 45) = REL(X, 10) 'NOV
Cells((i + (X + 1)), 47) = REL(X, 11) 'DEZ
Next X
End If
Next i

End Sub

Private Function BASE_PDM(ByVal nome As String) As Boolean
Dim l As Integer
Dim f As Integer
Dim NomeBase As String
Dim Coluna As Integer

BASE_PDM = False

f = Sheets("BASE").Cells(Rows.Count, 1).End(xlUp).Row
Coluna = 144

For i = 5 To f

NomeBase = Trim(Sheets("BASE").Cells(i, 1))

If nome = NomeBase Then
Call LIMPAR_REL
For y = 0 To 11
REL(0, y) = Sheets("BASE").Cells(i, (Coluna - 6)) 'FAT_PRODUTO
REL(1, y) = Sheets("BASE").Cells(i, (Coluna - 5)) 'MAR_PRODUTO
REL(2, y) = Sheets("BASE").Cells(i, (Coluna - 1)) 'FAT_SERVIÇO
REL(3, y) = Sheets("BASE").Cells(i, (Coluna)) 'EFIC_SERVIÇO
REL(4, y) = REL(0, y) + REL(2, y) 'TOL FAT
REL(5, y) = MEDIA_MARGEM(REL(1, y), REL(3, y)) 'MEDIA SERV
REL(6, y) = Sheets("BASE").Cells(i, (Coluna - 7)) 'PRODUTIVIDADE

Coluna = Coluna - 11
Next y
BASE_PDM = True
Exit Function
End If
Next i

End Function

Private Sub LIMPAR_REL()
For X = 0 To 6
For y = 0 To 11
REL(X, y) = 0
Next y
Next X
End Sub

Private Function MEDIA_MARGEM(ByVal M_PROD As Variant, ByVal M_SERV As Variant)

If M_PROD = "" Or M_SERV = "" Then
MEDIA_MARGEM = M_PROD + M_SERV
Else
MEDIA_MARGEM = (M_PROD + M_SERV) / 2
End If

End Function

Private Sub SomaLinha(ByVal l As Integer)
Dim item As String
Dim f As String
Dim cont As Integer

cont = 0

Call LIMPAR_REL

f = Cells(Rows.Count, Cool.End(xlUp).Row

For i = l To f Step 8

item = Cells(i, 2)

If item <> "" Then
If i <> l Then
For X = 0 To 6
If X = 1 Or X = 3 Or X = 5 Then
Cells((i + (X + 1)), 15) = REL(X, 0) / cont 'JAN
Cells((i + (X + 1)), 18) = REL(X, 1) / cont 'FEV
Cells((i + (X + 1)), 21) = REL(X, 2) / cont 'MAR
Cells((i + (X + 1)), 24) = REL(X, 3) / cont 'ABR
Cells((i + (X + 1)), 27) = REL(X, 4) / cont 'MAI
Cells((i + (X + 1)), 31) = REL(X, 5) / cont 'JUN
Cells((i + (X + 1)), 34) = REL(X, 6) / cont 'JUL
Cells((i + (X + 1)), 37) = REL(X, 7) / cont 'AGO
Cells((i + (X + 1)), 40) = REL(X, Cool / cont 'SET
Cells((i + (X + 1)), 43) = REL(X, 9) / cont 'OUT
Cells((i + (X + 1)), 45) = REL(X, 10) / cont 'NOV
Cells((i + (X + 1)), 47) = REL(X, 11) / cont 'DEZ
Else
Cells((i + (X + 1)), 15) = REL(X, 0) 'JAN
Cells((i + (X + 1)), 18) = REL(X, 1) 'FEV
Cells((i + (X + 1)), 21) = REL(X, 2) 'MAR
Cells((i + (X + 1)), 24) = REL(X, 3) 'ABR
Cells((i + (X + 1)), 27) = REL(X, 4) 'MAI
Cells((i + (X + 1)), 31) = REL(X, 5) 'JUN
Cells((i + (X + 1)), 34) = REL(X, 6) 'JUL
Cells((i + (X + 1)), 37) = REL(X, 7) 'AGO
Cells((i + (X + 1)), 40) = REL(X, Cool 'SET
Cells((i + (X + 1)), 43) = REL(X, 9) 'OUT
Cells((i + (X + 1)), 45) = REL(X, 10) 'NOV
Cells((i + (X + 1)), 47) = REL(X, 11) 'DEZ
End If
Next X
Call LIMPAR_REL
cont = 0
i = i + 8
End If
End If

For X = 0 To 6
REL(X, 0) = REL(X, 0) + Cells((i + (X + 1)), 15) 'JAN
REL(X, 1) = REL(X, 1) + Cells((i + (X + 1)), 18) 'FEV
REL(X, 2) = REL(X, 2) + Cells((i + (X + 1)), 21) 'MAR
REL(X, 3) = REL(X, 3) + Cells((i + (X + 1)), 24) 'ABR
REL(X, 4) = REL(X, 4) + Cells((i + (X + 1)), 27) 'MAI
REL(X, 5) = REL(X, 5) + Cells((i + (X + 1)), 31) 'JUN
REL(X, 6) = REL(X, 6) + Cells((i + (X + 1)), 34) 'JUL
REL(X, 7) = REL(X, 7) + Cells((i + (X + 1)), 37) 'AGO
REL(X, Cool = REL(X, Cool + Cells((i + (X + 1)), 40) 'SET
REL(X, 9) = REL(X, 9) + Cells((i + (X + 1)), 43) 'OUT
REL(X, 10) = REL(X, 10) + Cells((i + (X + 1)), 45) 'NOV
REL(X, 11) = REL(X, 11) + Cells((i + (X + 1)), 47) 'DEZ
Next X
cont = cont + 1
Next i

End Sub

Private Sub SomaTotal(ByVal l As Integer)
Dim item As String
Dim f As String
Dim cont As Integer

cont = 0

Call LIMPAR_REL

f = Cells(Rows.Count, Cool.End(xlUp).Row

For i = l To f Step 8

item = Cells(i, 2)

If item <> "" Then
If i <> l Then
For X = 0 To 6
REL(X, 0) = REL(X, 0) + Cells((i + (X + 1)), 15) 'JAN
REL(X, 1) = REL(X, 1) + Cells((i + (X + 1)), 18) 'FEV
REL(X, 2) = REL(X, 2) + Cells((i + (X + 1)), 21) 'MAR
REL(X, 3) = REL(X, 3) + Cells((i + (X + 1)), 24) 'ABR
REL(X, 4) = REL(X, 4) + Cells((i + (X + 1)), 27) 'MAI
REL(X, 5) = REL(X, 5) + Cells((i + (X + 1)), 31) 'JUN
REL(X, 6) = REL(X, 6) + Cells((i + (X + 1)), 34) 'JUL
REL(X, 7) = REL(X, 7) + Cells((i + (X + 1)), 37) 'AGO
REL(X, Cool = REL(X, Cool + Cells((i + (X + 1)), 40) 'SET
REL(X, 9) = REL(X, 9) + Cells((i + (X + 1)), 43) 'OUT
REL(X, 10) = REL(X, 10) + Cells((i + (X + 1)), 45) 'NOV
REL(X, 11) = REL(X, 11) + Cells((i + (X + 1)), 47) 'DEZ
Next X
cont = cont + 1
i = i + 8
End If
End If

If (f - 7) = i Then
For X = 0 To 6
If X = 1 Or X = 3 Or X = 5 Then
Cells((i + (X + 1)), 15) = REL(X, 0) / cont 'JAN
Cells((i + (X + 1)), 18) = REL(X, 1) / cont 'FEV
Cells((i + (X + 1)), 21) = REL(X, 2) / cont 'MAR
Cells((i + (X + 1)), 24) = REL(X, 3) / cont 'ABR
Cells((i + (X + 1)), 27) = REL(X, 4) / cont 'MAI
Cells((i + (X + 1)), 31) = REL(X, 5) / cont 'JUN
Cells((i + (X + 1)), 34) = REL(X, 6) / cont 'JUL
Cells((i + (X + 1)), 37) = REL(X, 7) / cont 'AGO
Cells((i + (X + 1)), 40) = REL(X, Cool / cont 'SET
Cells((i + (X + 1)), 43) = REL(X, 9) / cont 'OUT
Cells((i + (X + 1)), 45) = REL(X, 10) / cont 'NOV
Cells((i + (X + 1)), 47) = REL(X, 11) / cont 'DEZ
Else
Cells((i + (X + 1)), 15) = REL(X, 0) 'JAN
Cells((i + (X + 1)), 18) = REL(X, 1) 'FEV
Cells((i + (X + 1)), 21) = REL(X, 2) 'MAR
Cells((i + (X + 1)), 24) = REL(X, 3) 'ABR
Cells((i + (X + 1)), 27) = REL(X, 4) 'MAI
Cells((i + (X + 1)), 31) = REL(X, 5) 'JUN
Cells((i + (X + 1)), 34) = REL(X, 6) 'JUL
Cells((i + (X + 1)), 37) = REL(X, 7) 'AGO
Cells((i + (X + 1)), 40) = REL(X, Cool 'SET
Cells((i + (X + 1)), 43) = REL(X, 9) 'OUT
Cells((i + (X + 1)), 45) = REL(X, 10) 'NOV
Cells((i + (X + 1)), 47) = REL(X, 11) 'DEZ
End If
Next X
Exit Sub
End If

Next i

End Sub


-----------------------------

a saida mais facil que eu achei foi inserir a quantidade de linhas que vou usar e na linha que eu escolher .. isso foi facil, só nao estou conseguindo Copiar as ultimas linhas e colar onde eu inseri.
Ir para o topo Ir para baixo
Conteúdo patrocinado





Recortar e colar ultimas linhas e colar nas primeiras. Empty
MensagemAssunto: Re: Recortar e colar ultimas linhas e colar nas primeiras.   Recortar e colar ultimas linhas e colar nas primeiras. Empty

Ir para o topo Ir para baixo
 
Recortar e colar ultimas linhas e colar nas primeiras.
Ir para o topo 
Página 1 de 1
 Tópicos semelhantes
-
» Selecionar, recortar e colar linhas inteiras ao mesmo tempo em intervalos diferentes no Excel
» Copiar, Colar Etc ...
» Copiar e colar
» contar linhas
» Comparação de linhas

Permissões neste sub-fórumNão podes responder a tópicos
Fórum Excel Bácico, Avançado e Vba :: Avançado/VBA :: Excel Avançado/VBA-
Ir para: