desenare dreptunghiuri

[dip]

Buna ziua,
In fisierul atasat este scrisa o macrocomanda care deseneaza dreptunghiuri in functie de coordonatele X si Y din tabel.
1.Cum se rescrie macrocomanda folosind o instructiune for...next, ca sa treaca de la o inregistrare la alta, fara a fi nevoit sa scriu cod pentru fiecare rand (in realitate tabelul are zeci de inregistrari)?
2.Macrocomanda sa coloreze diferit dreptunghiul in functie de atributul din ultima coloana (pentru A o culoare, pentru B alta culoare).
Multumesc anticipat.

Cod: Selectaţi tot

Sub TRASEAZA()
'

    Sheets("grafic").Select
    Cells.Select
    Range("D1").Activate
    Selection.EntireRow.Hidden = False
    ActiveSheet.DrawingObjects.Select
    Selection.Delete
    Range("C3").Select
    
    ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, Range("C3").Value, Range("D3").Value, 90, 30).Select
    Application.CutCopyMode = False
    Selection.Formula = "=$B$3"
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    Selection.ShapeRange.TextFrame2.MarginLeft = 0
    Selection.ShapeRange.TextFrame2.MarginRight = 0
    Selection.ShapeRange.TextFrame2.MarginTop = 0
    Selection.ShapeRange.TextFrame2.MarginBottom = 0
    Selection.ShapeRange.Line.Weight = 2
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(20, 240, 20)
    
    ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, Range("C4").Value, Range("D4").Value, 90, 30).Select
    Application.CutCopyMode = False
    Selection.Formula = "=$B$4"
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    Selection.ShapeRange.TextFrame2.MarginLeft = 0
    Selection.ShapeRange.TextFrame2.MarginRight = 0
    Selection.ShapeRange.TextFrame2.MarginTop = 0
    Selection.ShapeRange.TextFrame2.MarginBottom = 0
    Selection.ShapeRange.Line.Weight = 2
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(20, 240, 20)
    
    ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, Range("C5").Value, Range("D5").Value, 90, 30).Select
    Application.CutCopyMode = False
    Selection.Formula = "=$B$5"
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    Selection.ShapeRange.TextFrame2.MarginLeft = 0
    Selection.ShapeRange.TextFrame2.MarginRight = 0
    Selection.ShapeRange.TextFrame2.MarginTop = 0
    Selection.ShapeRange.TextFrame2.MarginBottom = 0
    Selection.ShapeRange.Line.Weight = 2
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(20, 240, 20)
    
    ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, Range("C6").Value, Range("D6").Value, 90, 30).Select
    Application.CutCopyMode = False
    Selection.Formula = "=$B$6"
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    Selection.ShapeRange.TextFrame2.MarginLeft = 0
    Selection.ShapeRange.TextFrame2.MarginRight = 0
    Selection.ShapeRange.TextFrame2.MarginTop = 0
    Selection.ShapeRange.TextFrame2.MarginBottom = 0
    Selection.ShapeRange.Line.Weight = 2
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(20, 240, 20)
    
    ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, Range("C7").Value, Range("D7").Value, 90, 30).Select
    Application.CutCopyMode = False
    Selection.Formula = "=$B$7"
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    Selection.ShapeRange.TextFrame2.MarginLeft = 0
    Selection.ShapeRange.TextFrame2.MarginRight = 0
    Selection.ShapeRange.TextFrame2.MarginTop = 0
    Selection.ShapeRange.TextFrame2.MarginBottom = 0
    Selection.ShapeRange.Line.Weight = 2
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(20, 240, 20)

    Range("B2").Select
    MsgBox ("Gata!")
    
End Sub

[dip]

Cred c-am rezolvat:

Cod: Selectaţi tot

Sub deseneaza()
'

    Sheets("grafic").Select
    Cells.Select
    Range("D1").Activate
    Selection.EntireRow.Hidden = False
    ActiveSheet.DrawingObjects.Select
    Selection.Delete
    Range("C3").Select
    
For i = 3 To 210
    ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, Range("C" & i).Value, Range("D" & i).Value, 90, 10).Select
    Application.CutCopyMode = False
    Selection.Formula = "=$E$" & i
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    Selection.ShapeRange.TextFrame2.MarginLeft = 0
    Selection.ShapeRange.TextFrame2.MarginRight = 0
    Selection.ShapeRange.TextFrame2.MarginTop = 0
    Selection.ShapeRange.TextFrame2.MarginBottom = 0
    Selection.ShapeRange.Line.Weight = 2
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = Range("F" & i).Value
Next

    Range("B2").Select
    MsgBox ("Gata!")
    
End Sub

[Dr.Windows]

Nu am verificat codul postat de tine dar probabil ca este corect, sau mai exact functional, pentru ca pot exista mai multe solutii.

Eu prefer varianta urmatoare: Pentru a putea executa un cod intr-o structura repetitiva, trebuie sa ma conving ca functioneaza cel putin 1 data. Asta inseamna ca as putea crea o procedura cu parametrii - astea se pot apela apoi "repetitiv".

Atunci am creat o procedura care deseneaza formele:

Cod: Selectaţi tot

Sub DeseneazaForma(CoordX As Double, CoordY As Double, strText As String, AtributCuloare As Double)
    Dim shp As Shape
    Set shp = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, CoordX, CoordY, 90, 30)
    Application.CutCopyMode = False
    shp.TextFrame.Characters.Text = strText
    shp.TextFrame.Characters.Font.ColorIndex = 0
    shp.TextFrame2.VerticalAnchor = msoAnchorMiddle
    shp.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    shp.TextFrame2.MarginLeft = 0
    shp.TextFrame2.MarginRight = 0
    shp.TextFrame2.MarginTop = 0
    shp.TextFrame2.MarginBottom = 0
    shp.Line.Weight = 2
    shp.Fill.ForeColor.RGB = AtributCuloare
End Sub

Asa pot testa procedura "independent" si apoi o pot include intr-o structura repetitiva cum este for... next

Cod: Selectaţi tot

Sub DeseneazaToateFormele()
    For r = 3 To 7
        DeseneazaForma Range("C" & r).Value, Range("D" & r).Value, Range("B" & r).Value, Range("E" & r).Value
    Next r
End Sub

Mai trebuiue doar poate ajutstat parametrul pentru culoare, unde eu am folosit codul culorilor (rgbYellow=65535, rgbRed=255, etc)

[dip]

Mulţumesc, mai profesionist aşa!(rămâne să mă lămuresc cu exprimarea culorii printr-un singur număr întreg)

[TudyBTH]

Folositi ColorIndex
https://docs.microsoft.com/en-us/office ... colorindex

[Dr.Windows]

Din pacate nu exista proprietatea ColorIndex pentru ForeColor.

Ce s-ar putea face in schimb, sa inlocuiesti in cod linia:

Cod: Selectaţi tot

shp.Fill.ForeColor.RGB = AtributCuloare

cu

Cod: Selectaţi tot

shp.Fill.ForeColor.SchemeColor=AtributCuloare

Situatie in care poti folosi pentru valorile AtributCuloare valorile intre 1 si 8. Poti incerca cu mai multe, dar de la 9 (care este NEGRU) in sus, Incepe sa reia aceleasi culori.

Sau, daca nu sunt suficiente cele 8 culori, poti folosi 3 coloane pentru atributul de culoare si atunci poti utiliza functia RGB (si linia initiala de cod) pentru a recompune culoarea folosind cele 3 culori de baza.

[Dr.Windows]

Sau... de "distractie"... poti folosi pe coloana Atribut doar o culoare de fundal care va fi preluata si pentru culoarea formei.
Situatie in care se modifica procedura care va crea formele:

Cod: Selectaţi tot

Sub DeseneazaForma2(CoordX As Double, CoordY As Double, strText As String, AtributCuloare As Range)
    Dim shp As Shape
    Set shp = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, CoordX, CoordY, 90, 30)
    Application.CutCopyMode = False
    shp.TextFrame.Characters.Text = strText
    shp.TextFrame.Characters.Font.ColorIndex = 0
    shp.TextFrame2.VerticalAnchor = msoAnchorMiddle
    shp.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    shp.TextFrame2.MarginLeft = 0
    shp.TextFrame2.MarginRight = 0
    shp.TextFrame2.MarginTop = 0
    shp.TextFrame2.MarginBottom = 0
    shp.Line.Weight = 2
    shp.Fill.ForeColor.RGB = AtributCuloare.Interior.Color
End Sub

si evident si "apelul" in bucla:

Cod: Selectaţi tot

Sub DeseneazaToateFormele2()
    For r = 3 To 7
        DeseneazaForma2 Range("C" & r).Value, Range("D" & r).Value, Range("B" & r).Value, Range("E" & r)
    Next r
End Sub

[dip]

Imi trebuie niste culori mai deschise, o sa folosesc SchemeColor, am observat ca permite si alte nuante de culori in afara de cele 8 (pentru numere pana la 81).

[dip]

Subiectul l-am deschis pentru a realiza fisierul atasat. Pe scurs (detalii mai multe sunt in fisier), macrocomenzile din fisier transpun niste date (despre trenuri in circulatie) dintr-o forma tabelara intr-o forma grafica.
Problema ramasa de rezolvat (daca se poate rezolva): trenurile care sunt in statii apropiate si pe acelasi sens sa fie desenate decalat pe verticala ca sa nu se suprapuna (si sa nu mai fiu nevoit sa le mut manual de fiecare data. Daca sunt in aceeasi statie problema e rezolvata cu o coloana ajutatoare DL in foaia GRAFIC).