Supprimer une requêtes et connexion par VBA + optimisation

Le 02/03/2021 à 09:29

Bonjour,

NOTE: Exceptionnelement j'utilise Excel Office 365 pour ce topic.

J'ai une macro VBA qui crée une requêtes et connexion (voir photos) et qui viens chercher des informations sur le nouvelle onglet tout fonctionne parfiatement. J'aimerais juste que à la fin du programme cette connexion soit supprimé (car je ne peux pas relancer le programme sinon)

Cela doit être une simple ligne de code mais je ne trouve pas...

gr

Petit problème bonus si quelqu'un veut jetter un coup d'oeil sur l'optimisation:

Je joint mon programme car j'ai des problèmes d'optimisation.. Excel plante pourtant si je suis patient le programme finit par se terminer. Le problème c'est que je fait +400 recherches internet, j'ai essayé de mettre en place un Userform pour afficher la progression de 0 à 100% mais même le label ne se met pas a jour et se met en mode "à cesser de fonctionner"

A+

116csgo-inventorytoolv5.xlsm (41.83 Ko)
Le 02/03/2021 à 11:43

Bonjour,

L'enregistreur de macro me renvoi :

ActiveWorkbook.Connections("Connexion3").Delete

Reste à déterminer le noms des connexions que vous souhaitez supprimer.

Le 02/03/2021 à 12:25

C'est surprenant, j'ai essayé avec l'enregistreur de macro et il n'affichais rien !

J'aimerais supprimer toutes les connexions éxistante, mais je ne sais pas comment récuperer leur nom dans ce cas

Le 02/03/2021 à 12:35

Bonjour,

ThisWorkbook.Connections

Te renvoie normalement la collection des connections à ton classeur.

Peut être chercher à boucler à travers celle collection avec l'instruction proposée par Xmenpl (que je SALUT au passage :))

Cdlt,

Le 02/03/2021 à 12:48
Sub test()
    Dim Connexion As Object
    For Each Connexion In ThisWorkbook.Connections
        ThisWorkbook.Connections(Connexion).Delete
    Next Connexion
End Sub

Je ne suis pas chez moi pour tester, je vous dit ca ce soir mais visiblement cela devrais fonctionner ?

Merci à vous.

Je ne comprend pas que mon enregistreur de macro n'est pas réussis à trouver cette commande....

Et du coup j'avais fait une deuxieme demande dans mon poste pour voir si on ne pouvais pas "accelerer" mon programme, Je suis vraiment nul en optimisation

La il tourne avec ~400 lignes donc 400 sites internet à ouvrir mais a l'avenir ce sera encore plus !

Si nécessaire je ferais un nouveau post pour ce sujet quand mon programme sera 100% fonctionnel.

Merci a vous je repasse ce soir pour valider que mon problème est reglé

Le 02/03/2021 à 13:23
Gabin37 a écrit :

J'aimerais supprimer toutes les connexions éxistante, mais je ne sais pas comment récuperer leur nom dans ce cas

juste onglet "Données" puis clic sur connexions celà affiche les connexions du classeur.

Le 02/03/2021 à 13:25

Je sous entendais trouver le nom des connexions par VBA car elles sont crées par VBA et dès que je relance le prog, vba n'arrive plus à creer la connexion dèja existante

Le 02/03/2021 à 13:32

A l'ouverture de votre fichier exemple il y avait trois connexions

J'imagine que la création automatique les a appelée : simplement "Connexion +le numéro de création" a voir comment celà peut être utiliser

pour peut-être supprimer au fur et à mesure de leur création pour alléger votre code vba final ?

Le 02/03/2021 à 14:11

Alors, je me suis peut être mal exprimé, mais mes deux problèmes sont complétement dépendant je m'explique:

En utilisant l'API d'un site web je récupère une liste de 400 ID -> cette fameuse Connexion que je cherche à delete à la fin du prog (photo de mon tout premier post)

Par la suite je viens chercher la page HTML d'un AUTRE site internet grâce à ces 400 ID que j'ai trouvé:

ex: "http://csgo.exchange/item/" & ID

et dans ce code HTML je viens chercher des infos.

Donc en résumé, mon programme créer une connexion externe pour obtenir une liste de 400 ID ca c'est bon et après je viens éxécuter 400 fois:

Call Importer_Item(ID as String)

voici le code de ma procédure répété 400 fois:

Sub Importer_Item(ID As String)
ligne = 8
On Error GoTo fuck
'=============================================================
code = htmlCodePage("http://csgo.exchange/item/" & ID)
'Name Extract
Name = regexextract(code, "<div class=""bar"">.+</div>")
Name = Trim(regexreplace(Name, "</?div( class=""bar"")?>", ""))
'Price Extract
Price = regexextract(code, "<div class='statsInv'>.+</div><div")
Price = Trim(regexreplace(Price, "</?div( class='statsInv')?>", ""))
Price = Right(Price, Len(Price) - 8)
Price = Left(Price, Len(Price) - 4)
'=============================================================
espoir:
While Cells(ligne, 1) <> Name And Cells(ligne, 1) <> ""
ligne = ligne + 1
Wend

If Cells(ligne, 1) = "" Then
    Cells(ligne, 1) = Name
    Cells(ligne, 2) = 1
    Cells(ligne, 3) = Price
Else
    Cells(ligne, 2) = Cells(ligne, 2) + 1
End If
Exit Sub
fuck:
If Name <> "" Then GoTo espoir
While Cells(ligne, 1) <> Name And Cells(ligne, 1) <> ""
ligne = ligne + 1
Wend
Cells(ligne, 1) = ID
End Sub

évidemment, rechercher 400 fois une page web même html cela génere de la latence, et je voulais savoir si vous aviez des astuces pour alleger le tout.

PS: On peut se tutoyer c''est plus sympa ? =)

Le 02/03/2021 à 19:21

Problème tjrs pas résolu...

J'ai essayé avec cela:

    Dim Requete As Object
    For Each Requete In ThisWorkbook.Queries

        ThisWorkbook.Queries(Requete).Delete
    Next Requete

Marche po non plus,

En fait c'ets les requetes que je souhaite supprimer, pas les connexion, et l'enregistreur de macro ne donne rien

image
Le 02/03/2021 à 19:28

Bonjour,

Alors il faut aller chercher de ce côté je pense.

Cdlt,

Le 02/03/2021 à 20:15

Merci Ergotamine, problème tjrs pas résolu avec un boucle qui delete les queries je ne comprend pas..

Quand je lance mon programme j'ai ce msg d'erreur:

Une requête portant le nom 'ItemList' existe déja

seul moyen de corriger le prob: effacer manuellement la requête ItemList ..

Sub Inventory()

Dim cn
Dim qt As QueryTable
Dim ws As Worksheet
For Each cn In ThisWorkbook.Connections
    cn.Delete
Next
For Each ws In ThisWorkbook.Worksheets
    For Each qt In ws.QueryTables
        qt.Delete
    Next
Next ws

Dim Max_Item As Long
Range("A8:C65536").ClearContents
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
    Dim ID As String
    Dim Item_ID As String
    ID = Cells(1, 2)
    ActiveWorkbook.Queries.Add Name:="ItemList", Formula:= _
        "let" & Chr(13) & "" & Chr(10) & "    Source = Json.Document(Web.Contents(""https://steamcommunity.com/profiles/" & ID & "/inventory/json/730/2""))," & Chr(13) & "" & Chr(10) & "    rgInventory = Source[rgInventory]" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    rgInventory"
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=ItemList;Extended Properties=""""" _
        , Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array("SELECT * FROM [ItemList]")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .ListObject.DisplayName = "ItemList"
        .Refresh BackgroundQuery:=False
    End With
    ActiveSheet.Name = "ItemList"
    UserForm1.Show
    n = 2
    While Cells(n, 1) <> ""
        Max_Item = Max_Item + 1
        n = n + 1
    Wend
    n = 2
    While Cells(n, 1) <> ""
    UserForm1.Label1.Caption = ((n - 2) * 100) / Max_Item
    UserForm1.Repaint
    Item_ID = Cells(n, 1)
    Sheets("Steam Inventory").Activate
    Call Importer_Item(Item_ID)
    Sheets("ItemList").Activate
    n = n + 1
    Wend
Unload UserForm1
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Sheets("ItemList").Delete
Application.DisplayAlerts = True
End Sub
image

Je dois passer à coté de quelque chose d'évident

Le 02/03/2021 à 20:22

Bonjour,

Une piste : même avec un autre nom de query ça ne fonctionne pas ? Car Item et List étant 2 propriétés natives de VBA (notamment des array) j'ai peur qu'il y ai des effets de bords.

Cdlt,

Le 02/03/2021 à 21:19

Non ca ne fonctionne pas Ergotamine :/

Le 02/03/2021 à 21:23

Bonjour,

Pour le principe ?

Cdlt.

Public Sub Remove()
Dim cn As WorkbookConnection, qry As WorkbookQuery
    On Error Resume Next
    For Each cn In ActiveWorkbook.Connections
        cn.Delete
    Next cn
    For Each qry In ActiveWorkbook.Queries
        qry.Delete
    Next qry
End Sub
Le 02/03/2021 à 22:35

Jean-éric mon sauveur ! Merci à tout ceux qui ont participé ! Bonne soirée a vous

Le 02/03/2021 à 22:37

Bonjour,

Quelle est la subtilité qui n'allais pas ? L'absence de On Error Resume Next ?

Merci par avance.

Cdlt,

Le 02/03/2021 à 22:41

Je ne sais absolument pas! j'ai juste coller le code de jean-éric au début de ma macro!

Le 02/03/2021 à 22:42

Si tu reprends ton ancien code et que tu ajoutes juste le On Error Resume Next tu obtiens la même chose ? Car je n'arrive pas à voir la subtilité et j'aime bien comprendre ce qu'il se passe derrière les lettres :)

Le 03/03/2021 à 00:42

Bonjour,

Pour le fun et une meilleure compréhension de la chose !?

Cdlt

63csgo-inventorytoolv5-3.xlsm (37.79 Ko)
Public Sub Inventory_2()
Dim wb As Workbook
Dim ws As Worksheet, ws2 As Worksheet
Dim cn As WorkbookConnection
Dim qry As WorkbookQuery
Const qryName As String = "ItemList", qryDescription As String = "Import Json"
Dim qryFormula As String, ID As String
'Dim modeCalc As XlCalculation

    With Application
        'modeCalc = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Steam Inventory")

    For Each cn In wb.Connections
        cn.Delete
    Next cn

    With ws
        .Range("A8:C65536").ClearContents
        'ID = ws.Cells(1, 2).Value
        ID = "76561198184791823"
    End With

    qryFormula = "let" & Chr(13) & "" & Chr(10)
    qryFormula = qryFormula & "    Source = Json.Document(Web.Contents(""https://steamcommunity.com/profiles/" & ID & "/inventory/json/730/2""))," & Chr(13) & "" & Chr(10)
    qryFormula = qryFormula & "    rgInventory = Source[rgInventory]" & Chr(13) & "" & Chr(10)
    qryFormula = qryFormula & "in" & Chr(13) & "" & Chr(10)
    qryFormula = qryFormula & "    rgInventory"

    Set qry = wb.Queries.Add(qryName, qryFormula, qryDescription)

    Set ws2 = wb.Worksheets.Add(after:=ActiveSheet)
    ws2.Name = "ItemList"

    LoadToWorksheet qry, ws2

    qry.Delete

    'Application.Calculation = modeCalc
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = False
    'Worksheets("ItemList").Delete

End Sub

Private Sub LoadToWorksheet(query As WorkbookQuery, currentSheet As Worksheet)
    With currentSheet.ListObjects.Add( _
         SourceType:=0, _
         Source:="OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & query.Name, _
         Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdDefault
        .CommandText = Array("SELECT * FROM [" & query.Name & "]")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = False
        .Refresh BackgroundQuery:=False
    End With
End Sub
Rechercher des sujets similaires à "supprimer requetes connexion vba optimisation"