Import web, copier jusqu'à x puis coller
Résolu
Leghe59
Messages postés
36
Date d'inscription
Statut
Membre
Dernière intervention
-
Leghe59 Messages postés 36 Date d'inscription Statut Membre Dernière intervention -
Leghe59 Messages postés 36 Date d'inscription Statut Membre Dernière intervention -
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 :
Merci de votre attention, et de votre aide !
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 !
3 réponses
-
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
-
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ù leSheets("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.-
- 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
-
-
Nickel, grand merci !!
