Guru do Excel e Power BI

Fórum de Dúvidas sobre Excel e Power BI
https://gurudoexcel.com/

Agrupar shapes por cores

https://gurudoexcel.com/viewtopic.php?t=1110

Página 1 de 1

Agrupar shapes por cores

Enviado: 28 Dez 2015 às 12:27
por fmcblues
Boa tarde pessoal,

Utilizo o seguinte código para agrupar shapes no Excel (funciona perfeitamente):

Sub Agrupar()
ActiveSheet.Shapes.Range(Array("Forma1", "Forma2", "Forma3", "Forma4", "Forma5", "Forma6")).Select
Selection.ShapeRange.Group.Select
End Sub

Minha dúvida é a seguinte: teria como agrupar os shapes de acordo com as cores que possuem?
Por exemplo: tudo que for vermelho ficaria agrupado... Assim como tudo que fosse verde ficaria agrupado em outro grupo diferente do primeiro.

Agradeço mais uma vez pela ajuda e deixo um muito obrigado ao laennder e ao Reinaldo, por me ajudarem tão rapidamente em outro tópico.

Re: Agrupar shapes por cores

Enviado: 04 Jan 2016 às 12:55
por alexandrevba
Boa tarde!!


Considerando a cor verde cana dos retângulos veja se ajuda.
Para mais informações veja a fonte:
http://answers.microsoft.com/en-us/offi ... b=5&auth=1
Código: Selecionar todos
Sub AleVBA_1110()
    With ActiveSheet.Shapes
      If Selection.ShapeRange.Fill.ForeColor.SchemeColor = 11 Then
      ActiveSheet.Shapes.Range(Array("Retângulo 1", "Retângulo 2", "Retângulo 3")).Select
            Selection.ShapeRange.Group.Select
      End If
    End With
End Sub
Att

Re: Agrupar shapes por cores

Enviado: 05 Jan 2016 às 08:41
por fmcblues
Um bom dia a todos!

alexandrevba, não consegui aplicar esse método aqui. Não aconteceu nada. :?
Preciso disso para aplicar ao mapa depois que ele estiver colorido. Isso tudo para conseguir fazer o esquema da terceira aula sobre mapas interativos aqui do site do Guru do Excel.
Trabalho com regiões muito específicas do meu estado. Assim, não consigo encontrar imagens dessas áreas em nenhum lugar. Vou ter que criar na raça.
Somente depois de obter isso que poderei clicar sobre alguma região do mapa e conseguir fazer com que fiquem ampliadas (que é a finalidade da aula 3).
Além disso, ao invés de definir uma cor como no Fill.ForeColor.SchemeColor = 11, teria como dizer ao código: "Quero a cor da célula A1"?

Meu arranjo é bem grande:

"3100104", "3100203", "3100302", "3100401", "3100500", "3100609", "3100708", "3100807", "3100906", "3101003", "3101102", "3101201", "3101300", "3101409", "3101508", "3101607", "3101631", "3101706", "3101805", "3101904", "3102001", "3102050", "3102100", "3102209", "3102308", "3102407", "3102506", "3102605", "3102704", "3102803", "3102852", "3102902", "3103009", "3103108", "3103207", "3103306", "3103405", "3103504", "3103603", "3103702", "3103751", "3103801", "3103900", "3104007", "3104106", "3104205", "3104304", "3104403", "3104452", "3104502", "3104601", "3104700", "3104809", "3104908", "3105004", "3105103", "3105202", "3105301", "3105400", "3105509", "3105608", "3105707", "3105905", "3106002", "3106101", "3106200", "3106309", "3106408", "3106507", "3106606", "3106655", "3106705", "3106804", "3106903", "3107000", "3107109", "3107208", "3107307", "3107406", "3107505", "3107604", "3107703", "3107802", "3107901", "3108008", "3108107", "3108206", "3108255", "3108305", "3108404", "3108503", "3108552", "3108602", "3108701", "3108800", "3108909", "3109006", "3109105", "3109204", "3109253", "3109303", "3109402", "3109451", "3109501", "3109600", "3109709", "3109808", "3109907", "3110004", "3110103", "3110202", "3110301", "3110400", "3110509", "3110608", "3110707", "3110806", "3110905", "3111002", "3111101", "3111150", "3111200", "3111309", "3111408", "3111507", "3111606", "3111705", "3111804", "3111903", "3112000", "3112059", "3112109", "3112208", "3112307", "3112406", "3112505", "3112604", "3112653", "3112703", "3112802", "3112901", "3113008", "3113107", "3113206", "3113305", "3113404", "3113503", "3113602", "3113701", "3113800", "3113909", "3114006", "3114105", "3114204", "3114303", "3114402", "3114501", "3114550", "3114600", "3114709", "3114808", "3114907", "3115003", "3115102", "3115201", "3115300", "3115359", "3115409", "3115458", "3115474", "3115508", "3115607", "3115706", "3115805", "3115904", "3116001", "3116100", "3116159", "3116209", "3116308", "3116407", "3116506", "3116605", "3116704", "3116803", "3116902", "3117009", "3117108", "3117207", "3117306", "3117405", "3117504", "3117603", "3117702", "3117801", "3117836", "3117876", "3117900", "3118007", "3118106", "3118205", "3118304", "3118403", "3118502", "3118601", "3118700", "3118809", "3118908", "3119005", "3119104", "3119203", "3119302", "3119401", "3119500", "3119609", "3119708", "3119807", "3119906", "3119955", "3120003", "3120102", "3120151", "3120201", "3120300", "3120409", "3120508", "3120607", "3120706", "3120805", "3120839", "3120870", "3120904", "3121001", "3121100", "3121209", "3121258", "3121308", "3121407", "3121506", "3121605", "3121704", "3121803", "3121902", "3122009", "3122108", "3122207", "3122306", "3122355", "3122405", "3122454", "3122470", "3122504", "3122603", "3122702", "3122801", "3122900", "3123007", "3123106", "3123205", "3123304", "3123403", "3123502", "3123528", "3123601", "3123700", "3123809", "3123858", "3123908", "3124005", "3124104", "3124203", "3124302", "3124401", "3124500", "3124609", "3124708", "3124807", "3124906", "3125002", "3125101", "3125200", "3125309", "3125408", "3125507", "3125606", "3125705", "3125804", "3125903", "3125952", "3126000", "3126109", "3126208", "3126307", "3126406", "3126505", "3126604", "3126703", "3126752", "3126802", "3126901", "3126950", "3127008", "3127057", "3127073", "3127107", "3127206", "3127305", "3127339", "3127354", "3127370", "3127388", "3127404", "3127503", "3127602", "3127701", "3127800", "3127909", "3128006", "3128105", "3128204", "3128253", "3128303", "3128402", "3128501", "3128600", "3128709", "3128808", "3128907", "3129004", "3129103", "3129202", "3129301", "3129400", "3129509", "3129608", "3129657", "3129707", "3129806", "3129905", "3130002", "3130051", "3130101", "3130200", "3130309", "3130408", "3130507", "3130556", "3130606", "3130655", "3130705", "3130804", "3130903", "3131000", "3131109", "3131158", "3131208", "3131307", "3131406", "3131505", "3131604", "3131703", "3131802", "3131901", "3132008", "3132107", "3132206", "3132305", "3132404", "3132503", "3132602", "3132701", "3132800", "3132909", "3133006", "3133105", "3133204", "3133303", "3133402", "3133501", "3133600", "3133709", "3133758", "3133808", "3133907", "3134004", "3134103", "3134202", "3134301", "3134400", "3134509", "3134608", "3134707", "3134806", "3134905", "3135001", "3135050", "3135076", "3135100", "3135209", "3135308", "3135357", "3135407", "3135456", "3135506", "3135605", "3135704", "3135803", "3135902", "3136009", "3136108", "3136207", "3136306", "3136405", "3136504", "3136520", "3136553", "3136579", "3136603", "3136652", "3136702", "3136801", "3136900", "3136959", "3137007", "3137106", "3137205", "3137304", "3137403", "3137502", "3137536", "3137601", "3137700", "3137809", "3137908", "3138005", "3138104", "3138203", "3138302", "3138351", "3138401", "3138500", "3138609", "3138625", "3138658", "3138674", "3138682", "3138708", "3138807", "3138906", "3139003", "3139102", "3139201", "3139250", "3139300", "3139409", "3139508", "3139607", "3139706", "3139805", "3139904", "3140001", "3140100", "3140159", "3140209", "3140308", "3140407", "3140506", "3140530", "3140555", "3140605", "3140704", "3140803", "3140852", "3140902", "3141009", "3141108", "3141207", "3141306", "3141405", "3141504", "3141603", "3141702", "3141801", "3141900", "3142007", "3142106", "3142205", "3142254", "3142304", "3142403", "3142502", "3142601", "3142700", "3142809", "3142908", "3143005", "3143104", "3143153", "3143203", "3143302", "3143401", "3143450", "3143500", "3143609", "3143708", "3143807", "3143906", "3144003", "3144102", "3144201", "3144300", "3144359", "3144375", "3144409", "3144508", "3144607", "3144656", "3144672", "3144706", "3144805", "3144904", "3145000", "3145059", "3145109", "3145208", "3145307", "3145356", "3145372", "3145406", "3145455", "3145505", "3145604", "3145703", "3145802", "3145851", "3145877", "3145901", "3146008", "3146107", "3146206", "3146255", "3146305", "3146404", "3146503", "3146552", "3146602", "3146701", "3146750", "3146909", "3147006", "3147105", "3147204", "3147303", "3147402", "3147501", "3147600", "3147709", "3147808", "3147907", "3147956", "3148004", "3148103", "3148202", "3148301", "3148400", "3148509", "3148608", "3148707", "3148756", "3148806", "3148905", "3149002", "3149101", "3149150", "3149200", "3149309", "3149408", "3149507", "3149606", "3149705", "3149804", "3149903", "3149952", "3150000", "3150109", "3150158", "3150208", "3150307", "3150406", "3150505", "3150539", "3150570", "3150604", "3150703", "3150802", "3150901", "3151008", "3151107", "3151206", "3151305", "3151404", "3151503", "3151602", "3151701", "3151800", "3151909", "3152006", "3152105", "3152131", "3152170", "3152204", "3152303", "3152402", "3152501", "3152600", "3152709", "3152808", "3152907", "3153004", "3153103", "3153202", "3153301", "3153400", "3153509", "3153608", "3153707", "3153806", "3153905", "3154002", "3154101", "3154150", "3154200", "3154309", "3154408", "3154457", "3154507", "3154606", "3154705", "3154804", "3154903", "3155009", "3155108", "3155207", "3155306", "3155405", "3155504", "3155603", "3155702", "3155801", "3155900", "3156007", "3156106", "3156205", "3156304", "3156403", "3156452", "3156502", "3156601", "3156700", "3156809", "3156908", "3157005", "3157104", "3157203", "3157252", "3157278", "3157302", "3157336", "3157377", "3157401", "3157500", "3157609", "3157658", "3157708", "3157807", "3157906", "3158003", "3158102", "3158201", "3158300", "3158409", "3158508", "3158607", "3158706", "3158805", "3158904", "3158953", "3159001", "3159100", "3159209", "3159308", "3159357", "3159407", "3159506", "3159605", "3159704", "3159803", "3159902", "3160009", "3160108", "3160207", "3160306", "3160405", "3160454", "3160504", "3160603", "3160702", "3160801", "3160900", "3160959", "3161007", "3161056", "3161106", "3161205", "3161304", "3161403", "3161502", "3161601", "3161650", "3161700", "3161809", "3161908", "3162005", "3162104", "3162203", "3162252", "3162302", "3162401", "3162450", "3162500", "3162559", "3162575", "3162609", "3162658", "3162708", "3162807", "3162906", "3162922", "3162948", "3162955", "3163003", "3163102", "3163201", "3163300", "3163409", "3163508", "3163607", "3163706", "3163805", "3163904", "3164001", "3164100", "3164209", "3164308", "3164407", "3164431", "3164472", "3164506", "3164605", "3164704", "3164803", "3164902", "3165008", "3165107", "3165206", "3165305", "3165404", "3165503", "3165537", "3165552", "3165560", "3165578", "3165602", "3165701", "3165800", "3165909", "3166006", "3166105", "3166204", "3166303", "3166402", "3166501", "3166600", "3166709", "3166808", "3166907", "3166956", "3167004", "3167103", "3167202", "3167301", "3167400", "3167509", "3167608", "3167707", "3167806", "3167905", "3168002", "3168051", "3168101", "3168200", "3168309", "3168408", "3168507", "3168606", "3168705", "3168804", "3168903", "3169000", "3169059", "3169109", "3169208", "3169307", "3169356", "3169406", "3169505", "3169604", "3169703", "3169802", "3169901", "3170008", "3170057", "3170107", "3170206", "3170305", "3170404", "3170438", "3170479", "3170503", "3170529", "3170578", "3170602", "3170651", "3170701", "3170750", "3170800", "3170909", "3171006", "3171030", "3171071", "3171105", "3171154", "3171204", "3171303", "3171402", "3171501", "3171600", "3171709", "3171808", "3171907", "3172004", "3172103", "3172202"

Ufa... É muita doidera, mas uma hora funciona!

Muito obrigado

Re: Agrupar shapes por cores

Enviado: 05 Jan 2016 às 10:10
por Reinaldo
Sem ver o modelo fica um tanto quanto dificil, mas tente adaptar
Código: Selecionar todos
Sub agrupa()
Dim sH As Variant
Dim mArray() As String, x As Integer
ActiveSheet.Range("A1").Interior.ColorIndex = 10
ReDim Preserve mArray(0)
For Each sH In ActiveSheet.Shapes
    With sH
    .Select
        If Selection.ShapeRange.Fill.ForeColor.SchemeColor = ActiveSheet.Range("A1").Interior.ColorIndex Then
            x = UBound(mArray)
            mArray(x) = sH.Name
        End If
    ReDim Preserve mArray(x + 1)
    End With
Next
 ActiveSheet.Shapes.Range((mArray)).Select
Selection.ShapeRange.Group.Select
End Sub

Re: Agrupar shapes por cores

Enviado: 13 Jan 2016 às 12:25
por fmcblues
Boa tarde,

Não obtive êxito com as explicações dos colegas.
Irei marcar o tópico como finalizado e continuarei utilizando o código que havia apresentado anteriormente.

Sub Agrupar()
ActiveSheet.Shapes.Range(Array("Forma1", "Forma2", "Forma3", "Forma4", "Forma5", "Forma6")).Select
Selection.ShapeRange.Group.Select
End Sub

Muito obrigado a todos!

Flávio

Re: Agrupar shapes por cores

Enviado: 13 Jan 2016 às 12:59
por alexandrevba
Boa tarde!!

Visto que até agora (mesmo com minha resposta e a do reinaldo), mesmo assim vc não postou seu arquivo modelo e que nos meus testes e entendimento deram certo, não vejo outra forma de lhe ajudar, caso queira poste um arquivo modelo ou aguarde outro colaborador que possa resolver mesmo a questão.


Att

Re: Agrupar shapes por cores

Enviado: 13 Jan 2016 às 13:56
por fmcblues
Boa tarde alexandrevba!

Segue um arquivo com toda a explicação e aplicação da macro.
Peço desculpa pela minha grave falha em não enviar o arquivo anteriormente!

Muito obrigado pelo tempo dedicado por todos.

Re: Agrupar shapes por cores

Enviado: 14 Jan 2016 às 11:07
por Reinaldo
Veja no Anexo, uma possibilidade

Re: Agrupar shapes por cores

Enviado: 14 Jan 2016 às 12:49
por fmcblues
Boa Reinaldo!

Para o arquivo que você anexou, ficou muito bom. Funcionou direitinho!
Vou tentar adaptar aos meus mapas.
Com isso já irei ganhar muito tempo de serviço.
Vou aguardar mais uns 2 dias para fechar o tópico... Quem sabe mais alguém tenha pensado em algo.

Muito obrigado novamente!

Flávio

Re: Agrupar shapes por cores

Enviado: 18 Jan 2016 às 10:33
por alexandrevba
Bom dia!!

Desculpa pelo atraso, mas se o do reinaldo, não resolver eu espero que esse código ajuda.
Código: Selecionar todos
Sub AleVBA_1110()
    Dim sH As Variant
    Dim mArray() As String, x As Integer
    Dim counter As Integer
   
    ReDim mArray(0)
A:
    For Each sH In ActiveSheet.Shapes
        With sH
            If .Name Like "Group" & "*" Then
                sH.Ungroup
            Else
                If .Fill.ForeColor = ActiveSheet.Range("S1").Interior.Color Then
                  x = UBound(mArray)
                  mArray(x) = sH.Name
                  ReDim Preserve mArray(x + 1)
                End If
            End If
        End With
    Next

    If x = 0 And counter = 0 Then
      counter = counter + 1
      GoTo A:
    End If
   
    ActiveSheet.Shapes.Range((mArray)).Select
    Selection.ShapeRange.Group.Select
End Sub
Att

Agrupar shapes por cores

Enviado: 18 Jan 2016 às 12:53
por fmcblues
Boa tarde!

A resposta do Reinaldo já estava me atendia perfeitamente...
Mas essa sua foi ultra-mega-power fantástica.
Era exatamente isso que eu imaginava.

Muito obrigado a todos pelo tempo a paciência gastos na resolução desse problema.

\ o /
Todos os horários são UTC-03:00
Página 1 de 1
Powered by phpBB® Forum Software © phpBB Limited