Import web, copier jusqu'à x puis coller

Résolu/Fermé

Leghe59 Messages postés 34 Date d'inscription mercredi 14 juin 2017 Statut Membre Dernière intervention 17 avril 2021 - Modifié le 24 sept. 2020 à 15:48
Leghe59 Messages postés 34 Date d'inscription mercredi 14 juin 2017 Statut Membre Dernière intervention 17 avril 2021 - 25 sept. 2020 à 18:13

Hello la Team !

Lors d'un import web, je bloque sur le copier/coller d'un texte lors d'un saut de ligne.
Si le "Résumé" tient sur une cellule, pas de soucis. Par contre si il y a x sauts de ligne, le texte tient dans x cellules.
Ma question donc, comment copier les x cellules contenues entre "Résumé" et "Caractéristiques" de la feuille TEMP, dans une seule cellule de la feuille EXPORT ?

Le fichier Excel d'une ligne : https://www.cjoint.com/c/JIynT3aP8qL

Mon code :

Sub IMPORTDECITRE()
    Dim ISBN As String
    Derlig = Sheets("EXPORT").Range("A" & Rows.Count).End(xlUp).Row
    For compteur = 2 To 2
        ISBN = Sheets("EXPORT").Cells(compteur, 1)
        Sheets("TEMP").Cells.Clear
        Application.CutCopyMode = False
        With Sheets("TEMP").QueryTables.Add(Connection:="URL;https://www.decitre.fr/rechercher/result?q=" & ISBN _
            , Destination:=Sheets("TEMP").Range("$A$1"))
            .Name = ISBN
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = False
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlEntirePage
            .WebFormatting = xlWebFormattingAll
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
        End With
        With Sheets("TEMP")
            Set Col_A = .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
            SYNOP = Application.CountIf(Col_A, "*Résumé*")
            CARAC = Application.CountIf(Col_A, "*Caract*")
        If SYNOP > 0 Then
        Lig = 1
                Lig = .Columns("A").Find("Résumé", .Cells(Lig, "A"), , xlPart).Row
                Sheets("EXPORT").Cells(compteur, 7) = Sheets("TEMP").Cells(Lig + 1, 1).Value
                Sheets("EXPORT").Cells(compteur, 7).Interior.ColorIndex = 4
            Else
                Sheets("EXPORT").Cells(compteur, 7) = "inconnu"
                Sheets("EXPORT").Cells(compteur, 7).Interior.ColorIndex = 3
            End If
        End With
    Next
End Sub

Merci de votre attention, et de votre aide !

A voir également:

Import web, copier jusqu'à x puis coller
Copier coller pdf - Guide
Traduire une page web - Guide
Instagram web - Guide
Copier une vidéo youtube - Guide
Web office - Guide

3 réponses

Réponse 1 / 3

cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 728
24 sept. 2020 à 18:59

Bonjour,

voici un code à adapter:

Option Explicit
Sub copier()
Dim i As Integer
For i = 1 To 12 ' a adapter
Worksheets("Feuil2").Range("A1") = Worksheets("Feuil2").Range("A1") & Worksheets("Feuil1").Range("A" & i) & Chr(13) & Chr(10)' a la ligne sinon virgule ", "
Next
End Sub

Réponse 2 / 3

Leghe59 Messages postés 34 Date d'inscription mercredi 14 juin 2017 Statut Membre Dernière intervention 17 avril 2021
Modifié le 25 sept. 2020 à 10:40

Merci, mais je ne connais pas i à l'avance.
En fait, en feuille TEMP, ce dont j'ai besoin se trouve sous "Résumé", d'où le

Sheets("TEMP").Cells(Lig + 1, 1).Value

mais fait parfois 2, 3, voire x lignes, jusqu'à "Caractéristiques" comme dans le fichier déposé sur cjoint.

Leghe59 Messages postés 34 Date d'inscription mercredi 14 juin 2017 Statut Membre Dernière intervention 17 avril 2021
25 sept. 2020 à 10:41

cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 728 > Leghe59 Messages postés 34 Date d'inscription mercredi 14 juin 2017 Statut Membre Dernière intervention 17 avril 2021
Modifié le 25 sept. 2020 à 12:00

Il faut faire une recherche des mots comme ceci:

Option Explicit
'déclaration des variables :
Dim debut As Integer
Dim fin As Integer
Dim Derlig As Long
Dim compteur As Integer
Dim Col_A, SYNOP, CARAC, Lig
Dim i As Integer
Sub IMPORTDECITRE()
    Dim ISBN As String
    Derlig = Sheets("EXPORT").Range("A" & Rows.Count).End(xlUp).Row
    For compteur = 2 To 2
        ISBN = Sheets("EXPORT").Cells(compteur, 1)
        Sheets("TEMP").Cells.Clear
        Application.CutCopyMode = False
        With Sheets("TEMP").QueryTables.Add(Connection:="URL;https://www.decitre.fr/rechercher/result?q=" & ISBN _
            , Destination:=Sheets("TEMP").Range("$A$1"))
            .Name = ISBN
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = False
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlEntirePage
            .WebFormatting = xlWebFormattingAll
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
        End With
        With Sheets("TEMP")
            Set Col_A = .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
            SYNOP = Application.CountIf(Col_A, "*Résumé*")
            CARAC = Application.CountIf(Col_A, "*Caract*")
        If SYNOP > 0 Then
        Lig = 1
                Lig = .Columns("A").Find("Résumé", .Cells(Lig, "A"), , xlPart).Row
               debut = Lig + 1
                Lig = .Columns("A").Find("Caractéristiques", .Cells(Lig, "A"), , xlPart).Row
                fin = Lig - 1
                Sheets("EXPORT").Cells(compteur, 7).Interior.ColorIndex = 4
            Else
                Sheets("EXPORT").Cells(compteur, 7) = "inconnu"
                Sheets("EXPORT").Cells(compteur, 7).Interior.ColorIndex = 3
            End If
        End With
    Next
   For i = debut To fin
Sheets("EXPORT").Range("G" & Derlig) = Sheets("EXPORT").Range("G" & Derlig) & Sheets("TEMP").Range("A" & i) & Chr(13) & Chr(10) ' a la ligne sinon virgule ", "
Next
Sheets("EXPORT").Activate
End Sub

Si problème le classeur est disponible. Il suffit de demander!

@+ Le Pivert

Réponse 3 / 3

Leghe59 Messages postés 34 Date d'inscription mercredi 14 juin 2017 Statut Membre Dernière intervention 17 avril 2021
25 sept. 2020 à 18:13

Import web, copier jusqu'à x puis coller

3 réponses

Discussions similaires

Newsletters