Ajouter 5 lignes pour chaque ligne en utilisant des macros VBA

Question

Bonjour tout le monde, j'ai deux feuilles de calcul de Sheet1 que je copie dans Sheet2 en copiant les données sur chaque ligne une fois, maintenant je veux que mes données ressemblent à la version "À être" : La première colonne sera répétée 5 fois et les autres colonnes ne devraient apparaître qu'une seule fois. J'essaie mais ça ne fonctionne pas...

Je suis en train d'utiliser des Macros pour cela

    Function getLastRow(targetSheet As Worksheet, colLetter As String) As Integer
        Dim lastRow As Integer
        With targetSheet
            getLastRow = .Cells(.Rows.count, colLetter).End(xlUp).Row
        End With
    End Function

    Function getColumn(targetSheet As Worksheet, FindWord As String, Optional iRow As Integer = 1) As Integer
        Dim iCol As Integer
        Dim tmpString As String
        For iCol = 1 To getLastColumn(targetSheet, 2)
            'targetSheet.Activate
            tmpString = VBA.Replace(targetSheet.Cells(iRow, iCol).Value, "", "")
            If VBA.InStr(1, VBA.LCase(tmpString), VBA.Replace(VBA.LCase(FindWord), "", "")) Then
                getColumn = iCol
                Exit Function
            End If
        Next iCol

    End Function

Sub ProcFile()
Dim wsRaw As Worksheet: Set wsRaw = ThisWorkbook.Sheets("Sheet1")
Dim wsAR As Worksheet: Set wsAR = ThisWorkbook.Sheets("Sheet2")
Dim iRow, x, LRow, sRow, col As Long
Dim Tes1, Test2, Test3 As String

sRow = getLastRow(wsAR, "E") + 1
LRow = getLastRow(wsRaw, "A")

If wsRaw.Range("A2").Value = "" Then MsgBox "L'onglet de données brutes est vide !!", vbCritical: Exit Sub

For x = 2 To LRow

        Tes1 = wsRaw.Cells(x, getColumn(wsRaw, "Tes1")).Value
        Test2 = wsRaw.Cells(x, getColumn(wsRaw, "Test2")).Value
        Test3 = wsRaw.Cells(x, getColumn(wsRaw, "Test3")).Value

            For col = 3 To 45 Step 2
                If wsRaw.Cells(x, col).Value <> "" Then

                    wsAR.Range("A" & sRow).Value = Tes1
                    wsAR.Range("B" & sRow).Value = Test2
                    wsAR.Range("C" & sRow).Value = Test3

                    End If

            Next col
           sRow = sRow + 1

Next x

MsgBox "Fait !!"

End Sub

Feuille 1 Données brutes

Feuille 2 Données après l'exécution de la macro

Les données que j'obtiens dans mon exécution de macro :

Answer 1

Répéter les lignes

Aide rapide (Non testé)

Remplacez la ligne

sRow = sRow + 1

avec

sRow = sRow + 5

Au lieu des lignes :

wsAR.Range("A" & sRow).Value = Tes1
wsAR.Range("B" & sRow).Value = Test2
wsAR.Range("C" & sRow).Value = Test3

utilisez ce qui suit :

wsAR.Range("B" & sRow).Value = Test2
wsAR.Range("C" & sRow).Value = Test3
For sRow = sRow To sRow + 4
    wsAR.Range("A" & sRow).Value = Test1
Next sRow
sRow = sRow - 5

Réponse initiale

• Le suivant va écraser une plage de la manière suivante :

  • La première ligne (les en-têtes) reste la même.
  • Chaque valeur dans la première colonne sera écrite cinq fois, l'une en dessous de l'autre.
  • Les colonnes restantes ne seront écrites qu'une seule fois, laissant quatre cellules vides en dessous.

  Option Explicit

  Sub repeatRows()

  Const wsName As String = "Feuille2"
  Const RowsCount As Long = 4
  
  Dim wb As Workbook: Set wb = ThisWorkbook ' classeur contenant ce code
  
  Dim rg As Range: Set rg = wb.Worksheets(wsName).Range("A1").CurrentRegion
  
  Dim Data As Variant: Data = rg.Value
  
  Dim srCount As Long: srCount = UBound(Data, 1)
  Dim cCount As Long: cCount = UBound(Data, 2)
  Dim drCount As Long: drCount = (srCount - 1) * (RowsCount + 1) + 1
  
  Dim Result As Variant: ReDim Result(1 To drCount, 1 To cCount)
  
  Dim c As Long
  
  For c = 1 To cCount
      Result(1, c) = Data(1, c)
  Next c
  
  Dim n As Long: n = 1
  Dim r As Long, i As Long
  
  For r = 2 To srCount
      n = n + 1
      For c = 1 To cCount
          Result(n, c) = Data(r, c)
      Next c
      For i = 1 To RowsCount
          n = n + 1
          Result(n, 1) = Data(r, 1)
      Next i
  Next r
  
  rg.Resize(n).Value = Result

  End Sub