Import web, copier jusqu'à x puis coller [Résolu]

Signaler
Messages postés
23
Date d'inscription
mercredi 14 juin 2017
Statut
Membre
Dernière intervention
1 novembre 2020
 -
Messages postés
23
Date d'inscription
mercredi 14 juin 2017
Statut
Membre
Dernière intervention
1 novembre 2020
 -
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 !
Afficher la suite

3 réponses

Réponse 1 / 3
Messages postés
7162
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
6 janvier 2021
 592
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
Messages postés
23
Date d'inscription
mercredi 14 juin 2017
Statut
Membre
Dernière intervention
1 novembre 2020
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.
Signaler
Messages postés
23
Date d'inscription
mercredi 14 juin 2017
Statut
Membre
Dernière intervention
1 novembre 2020
Signaler
Messages postés
7162
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
6 janvier 2021
 592 >
Messages postés
23
Date d'inscription
mercredi 14 juin 2017
Statut
Membre
Dernière intervention
1 novembre 2020
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
Messages postés
23
Date d'inscription
mercredi 14 juin 2017
Statut
Membre
Dernière intervention
1 novembre 2020
Nickel, grand merci !!
Répondre Posez votre question