Copie vers ppt - loop avec critere de hauteur de cellule

[Carnage029]

Bonjour a tous

J'ai dans un gros fichier Excel cree une fonction permettant de copier une range dans une presentation PowerPoint.

Le code me permet de prendre donc la range avec la premiere ligne de titre et de copier le resultat.

Cependant j'aimerai modifier mon code pour non pas prendre 8 lignes par slide mais ajouter la ligne si le total des cellules a copier a une hauteur inferieure stricte a 550 pixels (mes rows ont toutes des hauteurs variables).

Je vais bien evidemment rajouter un test pour au moins copier une ligne (en plus du titre) si le test est faux pour eviter de tourner en rond...

Pour expliquer mon code, la premiere partie, sert a trier ma sheet "Open Recommendations" avec les criteres que je souhaite

Sub copyRecos(PR As Object, NewPowerPoint As Object, Title As String, SliN As Variant)

'Filter
    ThisWorkbook.Sheets("Open Recommendations").Activate
    Range("P1").Select
    ThisWorkbook.Worksheets("Open Recommendations").Sort.SortFields.Clear
    ThisWorkbook.Sheets("Open Recommendations").Sort.SortFields.Add Key:= _
        Range("P1"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ThisWorkbook.Worksheets("Open Recommendations").Sort
        .SetRange Range("A2:Q709")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Pui cette partie copie colle chaque groupe de 8 lignes (c'est cela que j'aimerai bien modifier).

lastr = ThisWorkbook.Sheets("Open Recommendations").Range("Q" & Rows.Count).End(xlUp).Row
If lastr = 2 Then Exit Sub
cpt = 1

Do While lastr > 0
    
    ThisWorkbook.Sheets("Open Recommendations").Range("A1:Q" & Application.Min(8 * cpt, ThisWorkbook.Sheets("Open Recommendations").Range("Q" & Rows.Count).End(xlUp).Row)).Select
    Selection.Copy
    
        Set SL = PR.Slides(SliN + cpt - 1)
        SL.Shapes(2).TextFrame.TextRange.Text = Title

            NewPowerPoint.ActiveWindow.Panes(2).Activate
            With NewPowerPoint.ActiveWindow.View
                .GotoSlide SliN + cpt - 1
                .PasteSpecial DataType:="02"
            End With

    ThisWorkbook.Sheets("Open Recommendations").Range("A2:Q" & 8 * cpt).Select
    Selection.EntireRow.Hidden = True
    cpt = cpt + 1
    lastr = lastr - 8
    
Loop

ThisWorkbook.Sheets("Open Recommendations").Cells.Select
Selection.EntireRow.Hidden = False

End Sub

Merci a tous

 

[Staple1600]

Re : Copie vers ppt - loop avec critere de hauteur de cellule

Bonsoir à tous

Carnage029
Ici, on accepte aussi les fichiers exemple en provenance de New-York.
Mais cela tu le sais déjà
https://www.excel-downloads.com/threads/vba-excel-to-powerpoint.229782/

 

[Carnage029]

Re : Copie vers ppt - loop avec critere de hauteur de cellule

Hello Staple

Merci de ta reponse, malheureusement je ne pense pas qu'un fichier exemple aide beaucoup, car la procedure que je cherche a modifier recoit des arguments qui sont pour simplifier un object PPT (numero de slide et titre en plus).

Si jamais tu penses que ca aide vraiment, je peux bricoler un fichier Excel avec des tests, mais dans l'ensemble je n'attend pas une solution toute faite mais plus une methode a adapter Etant autodidacte en VBA je commence a comprendre ce que j'ecris (ou tout du moins ce que je bricole a droite a gauche).

J'ai mis mon code au complet pour expliquer ce que je faisait, mais je pense que la seule ligne a modifier (voir remplacer par plusieurs) est celle ci:

ThisWorkbook.Sheets("Open Recommendations").Range("A1:Q" & Application.Min(8 * cpt, ThisWorkbook.Sheets("Open Recommendations").Range("Q" & Rows.Count).End(xlUp).Row)).Select

Je pensais partir d'une sorte de "add to selection" mais j'ai pas trouve de literature correspondante

Comment se porte la Bretagne natale ?

 

[Staple1600]

Re : Copie vers ppt - loop avec critere de hauteur de cellule

Re

Si jamais tu penses que ca aide vraiment, je peux bricoler un fichier Excel

Bricole, camarade, bricole
Car de mon point vue, c'est au demandeur de fournir un fichier exemple pour aider à résoudre sa question.
Cela évite surtout à ceux qui seront tentés de t'aider de perdre leur temps à créér un fichier qui existe déjà sur ton disque dur.
Donc à te relire ou pas avec un zip contenant un *.xls et un ppt.

NB: La Bretagne se porte aussi bien qu'elle le peut dans ce monde de dingues

 

[Carnage029]

Re : Copie vers ppt - loop avec critere de hauteur de cellule

Voila

J'ai fait un petit exemple tout simple, pour recapituler, je souhaite que au lieu de prendre 8 lignes (+titre) puis coller sur PPT, je prenne au maximum 555 pixels (evidemment si une ligne fait plus de 555 pixels, on la prend quand meme pour eviter de tourner en rond).

Merci a vous tous

NB: Je vais reexpliquer, un tiens vaut mieux que deux tu l'aura

Je souhaite que la macro, defille la liste des cellules non vides, pour copier (en image) la range partant de A1 jusqu'a F & lastrow en "blocs" de maximum 555 pixels de hauteur, et que chaque bloc comprenne la ligne de titre. en gerant le cas particulier ou ligneTitre + une seule autrel igne > 555 pixels on prend quand meme, pour eviter de tourner en rond.

 

[Staple1600]

Re : Copie vers ppt - loop avec critere de hauteur de cellule

Bonsoir à tous

Carnage029
C'est quoi cette contrainte des 555 pixels
Essaie de voir vers quoi peux t'orienter cet exemple

Sub testS()
MsgBox Application.ActiveWindow.PointsToScreenPixelsX(Selection.Height)'=556
MsgBox Application.ActiveWindow.PointsToScreenPixelsX(Range("A1:A35").Height) '=556
End Sub

(NB: Ici les lignes ont la hauteur standard de : 15)

 

[Carnage029]

Re : Copie vers ppt - loop avec critere de hauteur de cellule

le probleme c'est que les lignes sont importes d'un fichier et n'ont pas une hauteur fixe... en bricolant toute la journee j'ai reussi a faire un truc passable, mais a mon avis ca ne gere pas une multitude de bugs

Pour ceux qui passeraient par la et qui auraient le meme soucis, je partage mon code applique a mon vrai exemple

lastr = ThisWorkbook.Sheets("Open Recommendations").Range("Q" & Rows.Count).End(xlUp).Row
lastr2 = ThisWorkbook.Sheets("Open Recommendations").Range("Q" & Rows.Count).End(xlUp).Row - 1
If lastr = 2 Then Exit Sub
cpt = 1
mycpt = 0
mycpt2 = 0

Do While lastr > 0
    
    
    For i = ThisWorkbook.Sheets("Open Recommendations").Range("Q" & Rows.Count).End(xlUp).Row To 1 Step -1
    
        ThisWorkbook.Sheets("Open Recommendations").Range("A1:Q" & i).Select
        If Selection.Height < 460 And i <> 1 Then
            Selection.Copy
            mycpt = i
            lastr = lastr2 - mycpt
            mycpt2 = mycpt2 + i
            Exit For
        End If
    Next i

 

[Staple1600]

Re : Copie vers ppt - loop avec critere de hauteur de cellule

Re

Tu as vu mon précédent message ou pas ?

 

[Carnage029]

Re : Copie vers ppt - loop avec critere de hauteur de cellule

oui j'ai vu ton message, mais les msgbox sont toujours a 0, il doit y avoir un probleme d'activewindow je pense. Pour mon test a moi, je pars de la derniere ligne et tant que ca fait plus de X pixels j'enleve une ligne et je refais le test. Je pense que l'algorithme est bon, je vais juste essayer de faire du blindage sur les cas particuliers