使用 VBA 宏为每行添加 5 行

Question

Hi All i have two worksheets from Sheet1 i am copying to Sheet2 which copy data to each row once now i want my data should be look like "To be Version": First column will be repeated 5 time and other column should be only once i am trying but it does not working..

I am using Macros to do this

    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 "Raw Data tab is Empty!!", 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 "Done!!"

End Sub

Sheet 1 Raw Data

Sheet 2 Data in after macro excution

The Data i am getting in my Macro excution:

Answer 1

Repeat Rows

Quick Help (Not tested)

Replace the line

sRow = sRow + 1

with

sRow = sRow + 5

Instead of the lines:

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

use the following:

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

Initial Answer

• The following will overwrite a range in the following way:

  • The first row (the headers) stays the same.
  • Every value in the first column will be written five times, one below the other.
  • The remaining columns will be written only once leaving four empty cells below.

Option Explicit

Sub repeatRows()
    
    Const wsName As String = "Sheet2"
    Const RowsCount As Long = 4
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this 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