Este fórum está sendo desativado

[XGrosso]

Boas pessoal,
Já pus esta dúvida noutra secção do fórum, mas penso que esta seja a mais indicada.
O que pretendo é o seguinte: eu tenho uma tabela com 3 abas e através do que preencho na 1ª aba me vá preenchendo a 2ª aba e depois na 2ª aba vou preencher a 3ª coluna que vai fazer com que a 3ª aba seja preenchida automaticamente.
Para exemplificar eu vou prencher isto:
IdObjeto NCabos NTubos NTritubos
CO170001 1 3 3

Com isto pretendo que o Excel na 2ª aba me crie isto:
IdConduta IdTubo
CO170001 T170001
CO170001 T170002
CO170001 T170003
CO170001 T170004
CO170001 T170005
CO170001 T170006
CO170001 T170007
CO170001 T170008
CO170001 T170009
CO170001 T170010
CO170001 T170011
CO170001 T170012

De seguida preencho a 3ª coluna da 2ª aba, ficando com a tabela assim:
IdConduta IdTubo NCabos
CO170001 T170001 0
CO170001 T170002 0
CO170001 T170003 0
CO170001 T170004 2
CO170001 T170005 0
CO170001 T170006 0
CO170001 T170007 0
CO170001 T170008 0
CO170001 T170009 0
CO170001 T170010 0
CO170001 T170011 0
CO170001 T170012 0

Por fim na 3ª aba o Excel vai me criar isto:
IDCabo IDTubo IdConduta
CB170001 T170004 CO170001
CB170002 T170004 CO170001
Sendo que isto é um exemplo para 1 caso, o que pretendo que seja feito automaticamente é o que está a amarelo, os espaços que estão sem cor, sou eu que preencho. pois vou ter cerca de 10 000 condutas, que vão originar cerca da 100 000 tubos. Obrigado segue em anexo o ficheiro Excel de teste.

[alexandrevba]

Bom dia!!
Eu fiz somente a parte da guia Tubos, tente fazer o resto.

Código: Selecionar todos

Public Sub AleVBA4967()

    Dim rngSinglecell As Range
    Dim rngQuantityCells As Range
    Dim intCount As Integer

    Set rngQuantityCells = Range("E1", Range("E1").End(xlDown))
    For Each rngSinglecell In rngQuantityCells
        If IsNumeric(rngSinglecell.Value) Then
            If rngSinglecell.Value > 0 Then
                For intCount = 1 To rngSinglecell.Value
                    Range(rngSinglecell.Address).EntireRow.Copy Destination:=Sheets("Tubos").Range("A" & Rows.Count).End(xlUp).Offset(1)
                Next
            End If
        End If
    Next
    With Worksheets("Tubos")
    .Activate
        With Range("A1:E1")
            .Value = Array("IdConduta", "1", "2", "IdTubo", "NCabos")
            .Font.Bold = True
            .Font.ColorIndex = 2
            .Interior.ColorIndex = 1
        End With
        
        Range("B:C").Delete
        With Range("B2")
            .Formula = "=""T""&((RIGHT(A2,6)-1)+ROW(A1))"
            With .Resize(Range("A" & Rows.Count).End(xlUp).Row - 1)
                .FillDown
                .Copy
                .PasteSpecial xlPasteValues
            End With
        End With
        Columns.AutoFit
    End With
End Sub

Att

[XGrosso]

Obrigado amigo!! Vou já experimentar!