Question

如果在数据表的单元格中包含值x＆gt; 1，我想复制并粘贴包含该单元格的行“x”次。行将在下一个可用的空白行中粘贴x = 1。

TREVDAN 2 CENTRAL 3 GAL FAB 1 从此。

TREVDAN 1 TREVDAN 1 CENTRAL 1 CENTRAL 1 CENTRAL 1 GAL FAB 1 看起来像这样。

Answer 1

这对你有用。

Sub SpecialCopy()
    'Assuming A and B columns source columns
    Dim i As Long, k As Long
    Dim j As Long: j = 1
    For i = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
        k = 1
        Do While k <= Range("B" & i).Value
            'Assuming C and D are destination columns
            Range("C" & j).Value = Range("A" & i).Value
            Range("D" & j).Value = 1
            j = j + 1
            k = k + 1
        Loop
    Next i
End Sub

Answer 2

根据@Jeanno提供的答案，如果要将结果直接粘贴到原始表格的顶部，可以使用以下内容：

Sub SpecialCopy()

'Assuming A and B columns source columns
Dim i As Long, k As Long
Dim j As Long: j = 1
Dim ArrayLength As Long: ArrayLength = Application.WorksheetFunction.Sum(ActiveSheet.Range("B:B"))
ReDim MyArray(1 To ArrayLength) As String

For i = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
    k = 1
    Do While k <= Range("B" & i).Value
        MyArray(j) = Range("A" & i).Value
        j = j + 1
        k = k + 1
    Loop
Next i

For Each MyCell In Range("a1:a" & ArrayLength)
MyCell.Value = MyArray(MyCell.Row())
MyCell.Offset(0, 1).Value = 1
Next MyCell

End Sub

Excel VBA拆分行

2 个答案: