Olá gente eu tenho o código abaixo que ele precisa continuar fazendo o que faz, copiar as celulas e colar nas planilhas. porém as mesmas células que serão copiadas elas tem código e nesse caso ele vai copiar o valor que tiver aparecendo se for diferente de zero. ja tentei varias vezes e nao consegui fazer a mudança. por ter código na celula ele acaba copiando o codigo mesmo quando tem zero ou numeros nele e ele só copia a formula e não o valor informado =/.
eu ainda consegui trocar o 'Verificamos se o avlor é nulo
If i.Value <> "" Then tirei as aspas puz 0 mas não fez o esperado. comparei com outra que tinha aqui mas nao deu certo.
Sub Copy_Consolidado()
Dim Linha As Long
Dim sLinSheets As Long
Dim sRG As Range
Dim sCodigo
Dim sRow As Long
Dim sSht As Worksheet
Dim ShtCONSOLIDADO As Worksheet
Dim sRgColunas
Dim sRotulo
Dim iLinRotulo
Dim Col As String
Dim wb As Workbook
Set wb = ThisWorkbook
Set ShtCONSOLIDADO = wb.Sheets("CONSOLIDADO")
Linha = ShtCONSOLIDADO.Range("A2").End(xlDown).Row
Set sRG = ShtCONSOLIDADO.Range("A4:" & "A" & Linha)
For Each x In sRG
sRow = x.Row
Set sRgColunas = ShtCONSOLIDADO.Range("C" & sRow & ", I" & sRow & ",M" & sRow & ", O" & sRow & ",R" & sRow & ", T" & sRow & ",V" & sRow)
For Each i In sRgColunas
iLinRotulo = 2 'Linha do Cabeçalho
'Verificamos se o avlor é nulo
If i.Value <> "" Then
'Montamos a Letra das Colunas
Col = Split(i.Address(1, 0), "$")(0)
'Linha dos Rotulos (Cabeçalho)
sRotulo = Range(Col & iLinRotulo).Address(0, 0)
'Capturamos o codigo
sCodigo = x.Value
sRow = i.Row
'Montamos o nome da aba como o sCodigo
Set sSht = wb.Sheets(CStr(sCodigo))
sLinSheets = sSht.Range("A2").End(xlDown).Row + 1
'Copiamos para as abas
ShtCONSOLIDADO.Range(sRotulo).Copy Destination:=sSht.Range("A" & sLinSheets)
ShtCONSOLIDADO.Range(i.Address).Copy Destination:=sSht.Range("B" & sLinSheets)
'Na instrução abaixo estou supondo que a data que comentou seria da Coluna L -DATA ENVIO
'Se não for, é só ajustar
ShtCONSOLIDADO.Range("AA" & sRow).Copy Destination:=sSht.Range("C" & sLinSheets)
End If
Next i
Next
End Sub
Postado : 01/04/2018 8:35 pm