XL 2021 récupérer des cellules multilignes d'une feuille dans une autre

Claudinedu13

XLDnaute Nouveau
Bonsoir, j'ai besoin de votre aide

Sur ma feuil1 je clique sur le bouton "Remplir Feuil2" pour copier les cellules A7 et B7 sur la feuil2 dans la zone que j'ai nommée "description1" et "description2"

j'obtiens

feuil2.jpg


Alors que je voudrais

feuil3.jpg


Pour infos pour mon projet, les cellules de ma feuil 1 peuvent contenir 1, 2, 3, 4 lignes (pas plus).

J'espère que ma demande est claire




Merci
 

Pièces jointes

  • Classeur.xlsm
    31.3 KB · Affichages: 5
Solution
Re,
Un essai en PJ avec :
VB:
Sub TransfertSylvanu()
Dim T, DL%, C, Plage
Sheets("Feuil2").[A3:G100].ClearContents
Plage = Array("A7", "B7", "E7", "G7")
For Each C In Plage
    T = Split(Range(C), Chr(10))
    DL = 2 + Sheets("Feuil2").[A1000].End(xlUp).Row
    Sheets("Feuil2").Cells(DL, "A").Resize(1 + UBound(T), 1).Value = Application.Transpose(T)
Next C
End Sub

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonsoir Claudine,
Pas sur d'avoir bien compris, mais un essai en PJ avec :
VB:
Sub Transfert()
Dim T, DL%
Sheets("Feuil2").[A3:G100].ClearContents
T = Split([A7], Chr(10))
Sheets("Feuil2").[A3].Resize(1 + UBound(T), 1).Value = Application.Transpose(T)
T = Split([B7], Chr(10))
DL = 2 + Sheets("Feuil2").[A1000].End(xlUp).Row
Sheets("Feuil2").Cells(DL, "A").Resize(1 + UBound(T), 1).Value = Application.Transpose(T)
End Sub
 

Pièces jointes

  • Classeur.xlsm
    24 KB · Affichages: 4

Franc58

XLDnaute Occasionnel
Salut, voici ma proposition:

VB:
Sub CopyData()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim i As Long
    Dim lines() As String
    Dim line As Variant
    
    Set ws1 = ThisWorkbook.Sheets("Feuil1")
    Set ws2 = ThisWorkbook.Sheets("Feuil2")
    Set rng = ws1.Range("A2:B" & ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row)
    
    i = 4 
    For Each cell In rng
        If cell.Value <> "" Then
            lines = Split(cell.Value, Chr(10))
            For Each line In lines
                ws2.Cells(i, "A").Value = ws1.Cells(1, cell.Column).Value
                ws2.Cells(i, "B").Value = line
                i = i + 1
            Next line
            i = i + 1
        End If
    Next cell
End Sub
 

Claudinedu13

XLDnaute Nouveau
re,
encore une petite requête pour vous @sylvanu et @Franc58 (j'ai essayé seule mais je n'y arrive pas) , je teste vos codes pour voir lequel des 2 je vais mettre dans mon appli,
en plus des cellules A7, B7 je veux aussi rajouter le contenu des cellules E7 et G7 dans ma feuil2 avec le même système que vous m'avez codé
Vos codes sont dans le module 1
MERCI


classeur.jpg
 

Pièces jointes

  • Classeur.xlsm
    33.9 KB · Affichages: 3

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re,
Un essai en PJ avec :
VB:
Sub TransfertSylvanu()
Dim T, DL%, C, Plage
Sheets("Feuil2").[A3:G100].ClearContents
Plage = Array("A7", "B7", "E7", "G7")
For Each C In Plage
    T = Split(Range(C), Chr(10))
    DL = 2 + Sheets("Feuil2").[A1000].End(xlUp).Row
    Sheets("Feuil2").Cells(DL, "A").Resize(1 + UBound(T), 1).Value = Application.Transpose(T)
Next C
End Sub
 

Pièces jointes

  • Classeur (V2).xlsm
    24.5 KB · Affichages: 4

Franc58

XLDnaute Occasionnel
Salut, il suffit de modifier rng comme ceci:

VB:
Sub CopyData()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim i As Long
    Dim lines() As String
    Dim line As Variant
    
    Set ws1 = ThisWorkbook.Sheets("Feuil1")
    Set ws2 = ThisWorkbook.Sheets("Feuil2")
    Set rng = Union(ws1.Range("A2:B" & ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row), _
                ws1.Range("E2:E" & ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row), _
                ws1.Range("G2:G" & ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row))
    
    i = 4
    For Each cell In rng
        If cell.Value <> "" Then
            lines = Split(cell.Value, Chr(10))
            For Each line In lines
                ws2.Cells(i, "A").Value = ws1.Cells(1, cell.Column).Value
                ws2.Cells(i, "B").Value = line
                i = i + 1
            Next line
            i = i + 1
        End If
    Next cell
End Sub
 

Discussions similaires

Statistiques des forums

Discussions
313 198
Messages
2 096 144
Membres
106 503
dernier inscrit
ngomez