VBA- nombre de ligne par quantité et incrémentation

Bonjour,

J'aurais besoin à partir de la feuille IMMO de recopier les données dans DATA uniquement si la valeur en cellule A = P.

Pour exemple :
Dans la feuille IMMO en fonction de la quantité indiquée dans la cellule E2, il faut copier les cellules B2, C2 et D2 avec increment de + 1 de la cellule C2 sur la feuille DATA et recommencer pour chaque ligne

Je ne suis pas certain d'être très clair j’espère que mon fichier excel attaché est plus explicite. Je vous remercie de votre aide n'ayant aucune compétence en VBA.

Cordialement,

Bonsoir jeffctrla, le forum,

Un essai...

Sub Bouton1_Cliquer()
 Dim sh As Worksheet, i%, dl%, ws As Worksheet, lig%, j%

  Set ws = Sheets("DATA")
  Set sh = Sheets("IMMO")
      dl = sh.Range("A" & Rows.Count).End(xlUp).Row
    ws.Cells.ClearContents

    Application.ScreenUpdating = False

     lig = 1
   For i = 2 To dl
    For j = 1 To sh.Cells(i, 5)
     If sh.Cells(i, 1) = "P" Then
        ws.Cells(lig, 1) = sh.Cells(i, 2)
        ws.Cells(lig, 2) = sh.Cells(i, 3) & "_" & j
        ws.Cells(lig, 3) = sh.Cells(i, 4)
        lig = lig + 1
     End If
    Next j
   Next i
  ws.Activate
End Sub

Cordialement,

Autre tentative....normalement plus rapide....

Sub test()
  Dim sh As Worksheet, ws As Worksheet
  Dim i%, dl%, j%, k%
  Dim tablo, tabloR()

  Set ws = Sheets("DATA")
  Set sh = Sheets("IMMO")
      dl = sh.Range("A" & Rows.Count).End(xlUp).Row
   tablo = sh.Range("A1").CurrentRegion
       k = 0
    For i = 2 To UBound(tablo, 1)
     For j = 1 To tablo(i, 5)
      If tablo(i, 1) = "P" Then
        ReDim Preserve tabloR(1 To 3, 1 To k + 1)
          tabloR(1, 1 + k) = tablo(i, 2)
          tabloR(2, 1 + k) = tablo(i, 3) & "_" & j
          tabloR(3, 1 + k) = tablo(i, 4)
          k = k + 1
      End If
     Next j
    Next i
   On Error Resume Next
  ws.Cells.ClearContents
  ws.Range("A1").Resize(UBound(tabloR, 2), 3) = Application.Transpose(tabloR)
  ws.Activate
End Sub

Cordialement,

Bonjour,
Bonjour xorsankukai,

Public Sub test_2()
Dim ws As Worksheet, ws2 As Worksheet
Dim i As Long, j As Long, k As Long
Dim tbl, arr()

    Set ws = Sheets("DATA")
    ws.Cells(1).CurrentRegion.ClearContents
    '-------------------------------------------------------------------
    Set ws2 = Sheets("IMMO")
    tbl = ws2.Cells(1).CurrentRegion
    '-------------------------------------------------------------------
    For i = 2 To UBound(tbl, 1)
        For j = 1 To tbl(i, 5)
            If UCase(tbl(i, 1)) = "P" Then
                ReDim Preserve arr(3, k + 1)
                arr(0, k) = tbl(i, 2)
                arr(1, k) = tbl(i, 3) & "_" & j
                arr(2, k) = tbl(i, 4)
                k = k + 1
            End If
        Next j
    Next i
    '-------------------------------------------------------------------
    If k > 0 Then ws.Cells(1).Resize(k, 3) = Application.Transpose(arr)
    ws.Activate

End Sub

Cdlt.