Imprimir listagem especifica

Estou a criar um ficheiro para uso por diversos utilizadores e com recurso aos controlos e formulários para ser mais simples de usar por aqueles que detém menos conhecimentos.

Ora para atingir este objetivo estou perante um problema ao qual não encontro saída e sem ideias de como o fazer. Por isso passo a descrever com um exemplo fictício para ver se algum me pode ajudar

Tenho um conjunto de registos e que pretendo listar para impressora mas não no formato de trabela tal como está mas num formato especifico, ou seja:


Tomando por base a seguinte tabela

Numero Utilizador Departamento
888 888 001 Nome A Comercial
888 888 005 Nome B Logístico
888 888 004 Nome C Comercial
888 888 006 Nome D Comercial
888 888 003 Nome E Gerência
888 888 002 Nome F Logístico


Pretendo listar na impressora neste formato

Departamento Comercial
Numero Utilizador
888 888 001 Nome A
888 888 004 Nome C
888 888 006 Nome D

Departamento Gerência
Numero Utilizador
888 888 003 Nome E

Departamento Logístico
Numero Utilizador
888 888 005 Nome B
888 888 002 Nome F

Desde já agradeço a ajuda que for possível.

Boa tarde!!

Tente algo assim.

Código:

Sub AleVBA_988()
Dim Rng As Range, Dn As Range, c As Long
Set Rng = Range(Range("d2"), Range("d" & Rows.Count).End(xlUp))
ReDim Ray(1 To Rng.Count * 2, 1 To 3)
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
    If Not .exists(Dn.Value) Then
        .Add (Dn.Value), Dn
    Else
        Set .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
    End If
Next
Dim k As Variant, G As Range
For Each k In .keys
    c = c + 1
    Ray(c, 1) = "Departmento" & " " & k
    c = c + 1: Ray(c, 1) = "Numero": Ray(c, 2) = "User": Ray(c, 3) = "Nome"
For Each G In .Item(k)
    c = c + 1
    Ray(c, 1) = G.Offset(, -3).Value: Ray(c, 2) = G.Offset(, -2).Value: Ray(c, 3) = G.Offset(, -1).Value
Next G
Next k
Range("F1").Resize(c, 3) = Ray
End With

Att

Bom dia,

Muito obrigado, grande ajuda mesmo!
Já experimentei e funciona na perfeição

Cpts

alexandrevba escreveu:

Boa tarde!!

Tente algo assim.

Código:

Sub AleVBA_988()
Dim Rng As Range, Dn As Range, c As Long
Set Rng = Range(Range("d2"), Range("d" & Rows.Count).End(xlUp))
ReDim Ray(1 To Rng.Count * 2, 1 To 3)
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
    If Not .exists(Dn.Value) Then
        .Add (Dn.Value), Dn
    Else
        Set .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
    End If
Next
Dim k As Variant, G As Range
For Each k In .keys
    c = c + 1
    Ray(c, 1) = "Departmento" & " " & k
    c = c + 1: Ray(c, 1) = "Numero": Ray(c, 2) = "User": Ray(c, 3) = "Nome"
For Each G In .Item(k)
    c = c + 1
    Ray(c, 1) = G.Offset(, -3).Value: Ray(c, 2) = G.Offset(, -2).Value: Ray(c, 3) = G.Offset(, -1).Value
Next G
Next k
Range("F1").Resize(c, 3) = Ray
End With

Att

Bom dia!

Eu fico feliz em ajudar, obrigado pelo retorno!


Att