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

[Claudinedu13]

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

Alors que je voudrais

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

 

[sylvanu]

Bonsoir Claudine,
Pas sur d'avoir bien compris, mais un essai en PJ avec :

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

 

[Franc58]

Salut, voici ma proposition:

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]

Merci à tous les 2 @sylvanu et @Franc58 , c'est exactement ce que je voulais . Super

 

[Claudinedu13]

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

 

[sylvanu]

Re,
Un essai en PJ avec :

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

 

[Franc58]

Salut, il suffit de modifier rng comme ceci:

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

 

[Claudinedu13]

@sylvanu @Franc58 Merci à tous les deux de partager vos connaissances