Bonjour à tous

J'aimerais modifier mon petit calculateur afin que dans la listBox1 il s'affiche 2 infos supplémentaires

Actuellement quand je saisie un article il ne s'affiche que la désignation et la quantité .

Je n'arrive pas à y afficher à la suite son prix et le total (prix x quantité) sur la ligne puis passer à la suivante.

Un autre souci que je rencontre mais que je n'arrive pas à résoudre c'est de supprimer un article déjà saisie (par erreur) et de refaire un calcul du nouveau montant

J'ai bricolé avec la saisie négative de l'article erroné mais c'est pas top

Si quelqu'un à quelques pistes je suis preneur

Merci

 

Merci beaucoup c'est parfait.

Bonsoir Icedarts, le Forum,

 

En modifiant une partie du code précèdent comme suit (en rouge), ça devrait suffire pour répondre à cette nouvelle demande :

       'Complétude du tableau
        With Sheets("Données")
            For L = 1 To NbLignTab
                For C = 0 To NbColTab
                    With .Cells(Lmax + L + 1, C + 1)
                        .Value = TabDoc.Rows(L).Cells(C).innerText
                        If C = NbColTab Then
                            .Offset(0, 1).Value = vTabLiens(Lnk, 2)
                        End If
                    End With
                Next C
            Next L
        End With

En pièce jointe, le code en action.

 

Bien cordialement,

Et simplement avec controle H?
Tu mets dans la première cellule un espace et dans la seconde tu remplaces par rien.
Tu fais remplacer tout et terminé non?

Bonjour,

Merci ça répond exactement à mes attentes.
Juste une chose car je n'avais pas pensé aux doublons d'un lien à l'autre.

 

J'ai donc ajouter une colonne en page 1 avec une info pour chaque lien.
Est-il possible de rajouter cette info sur chaque ligne dans la page 2

Le lien 1 on récupère X lignes on ajoute l'info sur ces X lignes

On passe au lien 2 on ajoute l'info du lien 2 sur les X nouvelles lignes etc etc.

Exemple en pièce jointe ça sera plus explicite ^^

 

Merci d'avance.

Bonsoir verdanto,

 

Sans doute le sujet n'est-il plus d'actualité...

 

Compte tenu de la complexité du code recopié ici (origine allemande ?) et sans fichier joint pour aider à éclaircir un peu le problème, je n'avais d'abord pas l'intention de répondre à ta demande à vrai dire...

 

Mais juste au cas où (et avec un peu de chance !), je dirai que la solution se trouve dans ce morceau de code :

 

' Anzahl Zeitperioden T

  AnzahlT = 2
  'WorksheetFunction.CountIf(Sheets("SAISIE DES RISQUES").Range("F4:Z4"), "*SM*")
  activeCol = 4 + (AnzahlT * 2)

Ici, la variable "activeCol" prend une valeur de 4 + (2 * 2) = 8

(ce qui correspond en théorie à la colonne H, 8ème colonne)

 

Je pense qu'en affectant une valeur de 12 (soit colonne L), la suite du code devrait pouvoir répondre à ton besoin. ATTENTION, cependant : une telle modification impliquera forcément d'autres répercutions ailleurs dans ton code !!!

 

Te souhaitant bonne chance,

Bien cordialement,

 

 

Bonsoir Icedarts, le Forum,

 

Tu trouveras en pièce-jointe sans doute une façon de faire :

 

DANS UN MODULE DE CODE STANDARD (ex : Module1)

Option Explicit

Sub RecupDatas()
' myDearFriend! - www.mdf-xlpages.com
' Mars 2023

' Nécessite une référence à "Microsoft HTML Object Library"
Dim vTabLiens As Variant
Dim iDoc As New MSHTML.HTMLDocument
Dim TabDoc As HTMLTable
Dim Lnk As Long, NbLignTab As Long, Lmax As Long, L As Long
Dim NbColTab As Byte, C As Byte
    'Liste des liens
    vTabLiens = Sheets("Liens").Cells(1, 1).CurrentRegion.Value
    'Pour chaque lien
    For Lnk = 1 To UBound(vTabLiens, 1)
        'Récup table datas
        With CreateObject("MSXML2.XMLHTTP")
            .Open "GET", vTabLiens(Lnk, 1), False
            .send
            iDoc.body.innerHTML = .responseText
        End With
        Set TabDoc = iDoc.getElementById("tableSort")
        
        NbLignTab = TabDoc.Rows.Length - 1
        NbColTab = TabDoc.Rows(0).Cells.Length - 1
        
        'Complétude du tableau
        With Sheets("Données")
            For L = 1 To NbLignTab
                For C = 0 To NbColTab
                    .Cells(Lmax + L + 1, C + 1).Value = TabDoc.Rows(L).Cells(C).innerText
                Next C
            Next L
        End With
        Lmax = Lmax + NbLignTab
    Next Lnk
    
    MsgBox "Récup terminée !"
    
    Set TabDoc = Nothing
    Set iDoc = Nothing
End Sub

Nb : tu n'as pas besoin de faire usage d'un webBrowser pour le fonctionnement de ce code.

 

En espérant t'avoir aidé.

 

Bien cordialement,

 

Bonjour à tous,

Il y a une quinzaine d'années j'ai fait une demande un peu similaire.
J'ai retrouver les discussions et les anciens classeurs mais il semble que certaines valeurs dans les codes ne soient plus correct, j'ai notamment une erreur avec webbrowser.

Voila ce que je souhaite faire.
Dans le classeur joint vous verrez en page 1 une liste de lien.
Liste réduite a 5 pour les tests mais en finalité il devrait y en avoir des dizaines
Le code doit cliquer sur chaque lien pour ouvrir une page web
Sur cette page il n'y a qu'un tableau
Je souhaite que les données de chaque tableau soit accumuler en page 2 du classeur.

Merci d'avance pour votre aide.

Bonjour,

 

J’aimerais modifier une macro d’un fichier Excel que j’ai récupéré.

Cette macro crée un graphique dans l’onglet EVALUATION DES RISQUES sur la base de données des colonnes F,G,H,I de l’onglet SAISIE DES RISQUES.

J’aimerais que la macro prenne comme source les colonnes L,M au lieux des colonnes H,I.

Que dois-je modifier dans la macro ci-dessous :

 

Sub bubbles()

Dim bubble_breite As Integer

Dim bubble_hoehe As Integer

Dim fontcolor_bubble As String

Dim fontstyle_bubble As String

 

Dim delta_x As Double

Dim delta_y As Double

Dim delta_delta_x As Double

Dim delta_delta_y As Double

Dim upper_left_x As Double

Dim upper_left_y As Double

 

' sti: variable riskono und eingeführt

Dim risikono(100) As Integer

Dim wahrscheinlichkeit(100) As Integer

Dim auswirkung(100) As Integer

Dim counter(5, 5) As Integer

Dim x As Integer

Dim y As Integer

Dim k As Double

Dim AnzahlEintraege As Integer

Dim AnzahlT As Integer

Dim t As String

 

' Initalisierungen

bubble_breite = 18

bubble_hoehe = 18

fontcolor_bubble = 1

fontstyle_bubble = "Standard"

 

' counter zuruecksetzen

  For i = 0 To 5

    For j = 0 To 5

      counter(i, j) = 0

    Next j

  Next i

 

' bubbles loeschen

  Call erase_bubbles

   

' Anzahl Risiken

  AnzahlEintraege = WorksheetFunction.CountIf(Sheets("SAISIE DES RISQUES").Range("A4:A205"), ">0")

 

' Anzahl Zeitperioden T

  AnzahlT = 2

  'WorksheetFunction.CountIf(Sheets("SAISIE DES RISQUES").Range("F4:Z4"), "*SM*")

  activeCol = 4 + (AnzahlT * 2)

 

For k = 1 To AnzahlT

    'daten auslesen

    For i = 1 To 100

    ' sti: variable risikono eingeführt und neue abfrage für top risiken

    risikono(i) = CInt(Sheets("SAISIE DES RISQUES").Cells(i + 3, 1).Value)

    wahrscheinlichkeit(i) = 0

    auswirkung(i) = 0

    If Sheets("SAISIE DES RISQUES").Cells(i + 3, 5).Value = "oui" Then

       If Sheets("SAISIE DES RISQUES").Cells(i + 3, activeCol).Value = " " Then wahrscheinlichkeit(i) = 0 Else wahrscheinlichkeit(i) = CInt(Sheets("SAISIE DES RISQUES").Cells(i + 3, activeCol).Value)

       If Sheets("SAISIE DES RISQUES").Cells(i + 3, activeCol + 1).Value = " " Then auswirkung(i) = 0 Else auswirkung(i) = CInt(Sheets("SAISIE DES RISQUES").Cells(i + 3, activeCol + 1).Value)

    End If

    Next i

   

' bubbles zeichnen

    upper_left_x = Sheets("MODELE").Cells(4, 3).Left

    upper_left_y = Sheets("MODELE").Cells(4, 3).Top

    delta_x = Sheets("MODELE").Cells(4, 3).Width

    delta_y = Sheets("MODELE").Cells(4, 3).Height

    delta_delta_x = bubble_breite + (delta_x - 3 * bubble_breite) / 10

    upper_left_x = upper_left_x + (delta_x - 3 * bubble_breite) / 10

    delta_delta_y = bubble_hoehe + (delta_y - 3 * bubble_hoehe) / 10

    upper_left_y = upper_left_y + (delta_y - 3 * bubble_hoehe) / 10

    i = 1

   

    For u = 1 To AnzahlEintraege

        x = upper_left_x + (auswirkung(i) - 1) * delta_x

        y = upper_left_y + (5 - wahrscheinlichkeit(i)) * delta_y

        x = x + (counter(wahrscheinlichkeit(i), auswirkung(i)) Mod 4) * delta_delta_x

        y = y + ((counter(wahrscheinlichkeit(i), auswirkung(i)) - counter(wahrscheinlichkeit(i), auswirkung(i)) Mod 4) / 4) * delta_delta_y

       

        If wahrscheinlichkeit(i) = 0 Then

            counter(wahrscheinlichkeit(i), auswirkung(i)) = counter(wahrscheinlichkeit(i), auswirkung(i)) + 1

           

            Else

            Call add_bubble(x, y, bubble_breite, bubble_hoehe, risikono(i), k)

            counter(wahrscheinlichkeit(i), auswirkung(i)) = counter(wahrscheinlichkeit(i), auswirkung(i)) + 1

        End If

        i = i + 1

   

    Next u

    Cells(1, 1).Select

    activeCol = activeCol - 2

   

    

Next k

End Sub

 

Sub erase_bubbles()

    Sheets("EVALUATION DES RISQUES").Select

    Application.DisplayAlerts = False

    ActiveWindow.SelectedSheets.Delete

    Sheets("MODELE").Select

    Sheets("MODELE").Copy After:=Sheets("SAISIE DES RISQUES")

    Sheets("MODELE (2)").Select

    Sheets("MODELE (2)").Name = "EVALUATION DES RISQUES"

End Sub

 

Sub add_bubble(ByVal x As Double, ByVal y As Double, ByVal bubble_breite, ByVal bubble_hoehe, ByVal z As Integer, ByVal k As Double)

       

    If k = 1 Then

        bubble_breite = 18

        bubble_hoehe = 18

        Fontfarbe_bubble = 2

        fontstyle_bubble = "Bold"

    Else

        Fontfarbe_bubble = 16

    End If

           

        ActiveSheet.Shapes.AddShape(msoShapeOval, x, y, bubble_breite, bubble_hoehe).Select

        Selection.Characters.Text = z

        Selection.ShapeRange.Line.Transparency = 1

       

     ' Farbe für Bubbles bestimmen

    

    Select Case k

        Case 1

            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(67, 69, 42)

        Case 2

            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(196, 189, 151)

            Selection.ShapeRange.ZOrder (1)

        Case 3

            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(238, 236, 225)

            Selection.ShapeRange.ZOrder (1)

    End Select

   

 

    With Selection.Characters(Start:=0, Length:=2).Font

        .Name = "Arial"

        .FontStyle = fontstyle_bubble

        .Size = 8

        .Strikethrough = False

        .Superscript = False

        .Subscript = False

        .OutlineFont = False

        .Shadow = False

        .Underline = xlUnderlineStyleNone

        .ColorIndex = Fontfarbe_bubble

    End With

    With Selection

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlCenter

        .Orientation = xlHorizontal

        .AutoSize = False

    End With

End Sub

Merci Didier c'est parfait..... sauf que j'aurais aimé avoir la ligne qui s'inscrive sur la ligne de la cellule active exemple si je double click sur B17 la ligne B17 est remplie et non la premiere ligne vide.

Merci

 

 

SUITE

 

Impeccable avec

Lig = ActiveCell.Row

 

Un grand merci à toi