根据值乘以该值将行复制到新的 Sheet

Question

我看过很多关于这个问题的答案，但它们似乎都无法正常工作。我在 Sheet 1:

中有这个数据集

Animal 1 | Cat  | 5 | Male            
Animal 2 | Mouse| 3 | Female    
Animal 3 | Dog  | 1 | Male

我想在 Sheet 2 上通过在 Sheet 1 上按下命令按钮来获得它：

Animal 1 | Cat  | 5 | Male
Animal 1 | Cat  | 5 | Male
Animal 1 | Cat  | 5 | Male
Animal 1 | Cat  | 5 | Male
Animal 1 | Cat  | 5 | Male
Animal 2 | Mouse| 3 | Female
Animal 2 | Mouse| 3 | Female
Animal 2 | Mouse| 3 | Female
Animal 3 | Dog  | 1 | Male

请记住，这是一个示例，我的数据集有 40 列和超过 1500 行，我要复制的值在 C 列中。

到目前为止我用代码完成的工作是这样的：

Private Sub CommandButton1_Click()
    
    Dim currentRow As Long
    Dim currentNewSheetRow As Long: currentNewSheetRow = 1

    For currentRow = 1 To 1547 'The last row of your data
    Dim timesToDuplicate As Integer
    timesToDuplicate = CInt(Worksheets("Sheet1").Range("C" & currentRow).Value)
    
    Dim i As Integer
    For i = 1 To timesToDuplicate
        Sheet2.Range("A" & currentNewSheetRow).EntireRow.Value2 = Sheet1.Range("A" & currentRow).EntireRow.Value2
        Sheet2.Range("B" & currentNewSheetRow).EntireRow.Value2 = Sheet1.Range("B" & currentRow).EntireRow.Value2
        Sheet2.Range("C" & currentNewSheetRow).EntireRow.Value2 = Sheet1.Range("C" & currentRow).EntireRow.Value2
        Sheet2.Range("D" & currentNewSheetRow).EntireRow.Value2 = Sheet1.Range("D" & currentRow).EntireRow.Value2
        Sheet2.Range("E" & currentNewSheetRow).EntireRow.Value2 = Sheet1.Range("E" & currentRow).EntireRow.Value2
        Sheet2.Range("F" & currentNewSheetRow).EntireRow.Value2 = Sheet1.Range("F" & currentRow).EntireRow.Value2
        Sheet2.Range("G" & currentNewSheetRow).EntireRow.Value2 = Sheet1.Range("G" & currentRow).EntireRow.Value2
        Sheet2.Range("H" & currentNewSheetRow).EntireRow.Value2 = Sheet1.Range("H" & currentRow).EntireRow.Value2
        Sheet2.Range("I" & currentNewSheetRow).EntireRow.Value2 = Sheet1.Range("I" & currentRow).EntireRow.Value2
        Sheet2.Range("J" & currentNewSheetRow).EntireRow.Value2 = Sheet1.Range("J" & currentRow).EntireRow.Value2
        Sheet2.Range("K" & currentNewSheetRow).EntireRow.Value2 = Sheet1.Range("K" & currentRow).EntireRow.Value2
        'Continuous
        currentNewSheetRow = currentNewSheetRow + 1
    Next i
Next currentRow

End Sub

谢谢！

Answer 1

试试这个代码：

Option Explicit

Sub Demo2()
    Dim lastRow As Long, lastColumn As Long, rowIndex As Long
    Dim srcSht As Worksheet, destSht As Worksheet
    Dim timesToDuplicate As Long, i As Long, j As Long, k As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set srcSht = ThisWorkbook.Sheets("Sheet5")  'sheet with data
    Set destSht = ThisWorkbook.Sheets("Sheet6") 'output sheet

    lastRow = srcSht.Cells(Rows.Count, "A").End(xlUp).Row      'last row with data
    lastColumn = Cells(1, Columns.Count).End(xlToLeft).Column   'number of columns

    rowIndex = 1
    For i = 1 To lastRow                                'loop for all the rows with data
        timesToDuplicate = srcSht.Cells(i, 3).Value     'get number of times row to be displayed
        For j = 1 To timesToDuplicate                   'loop for displaying row timesToDuplicate no. of times
            For k = 1 To lastColumn                     'loop of all columns
                destSht.Cells(rowIndex, k) = srcSht.Cells(i, k) 'display data
            Next k
            rowIndex = rowIndex + 1
        Next j
    Next i

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

根据值乘以该值将行复制到新的 Sheet

Copy rows to a new Sheet based on a value, times the value

vba

excel

excel-2016