將行復制到基於值的新工作表中，乘以值

Question

我已經看到很多這個問題的答案，但它們似乎不能正常工作。我有這樣的數據集，表1：

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

而且我想通過按表1的命令按鈕讓這個在第2頁：

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