那些遇到过的问题

如何重复行

Eua*_*M28 3 excel vba

我想将工作表中的每一行复制 57 次，跨 39 列（在结果之后，意味着每条记录将有 58 个重复项）。

我的一些记录的片段（请记住，有 39 列，片段无法截取完整视图）：
原始数据

我正在寻找的结果（注意：此示例每行有 10 个重复项，而不是 58 个，因为屏幕截图太大）。原始文件有超过 5000 条记录，所以我知道我使用的任何代码都需要一段时间才能加载。
期望的结果

下面的代码不会重复行，但确保每行在 39 列（A 到 AM）的每行之间有 57 个空白行的间隙。这将是一个更长、更复杂的完成任务的方式，因为我必须找到一种方法来填补空白。因此，为什么我要发布这个问题，因为必须有一种更有效的方法。

Sub Duplication()

Dim lastRow As Long
lastRow = Sheets("MasterSheet").Range("A" & Rows.Count).End(xlUp).Row

For i = lastRow To 3 Step -1
    Cells(i, 1).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 2).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 3).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 4).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 5).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 6).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 7).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 8).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 9).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 10).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 11).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 12).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 13).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 14).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 15).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 16).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 17).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 18).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 19).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 20).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 21).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 22).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 23).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 24).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 25).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 26).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 27).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 28).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 29).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 30).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 31).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 32).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 33).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 34).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 35).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 36).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 37).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 38).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 39).Resize(57).Insert Shift:=xlDown
Next    

End Sub
Run Code Online (Sandbox Code Playgroud)

Fox*_*rns 6

您可以将所有数据放入数组中，并从那里循环粘贴值：

在此输入图像描述

Sub test()
Dim i As Long, j As Long
Dim LastColumn As Long, LastRow As Long
Dim MyData As Variant
Dim HowManyCopies As Long, MyCounter As Long, CurrentRow As Long

Application.ScreenUpdating = False

'get last column, in your case 39, here is just 4
LastColumn = 4

'get last non blank row
LastRow = Range("A" & Rows.Count).End(xlUp).Row

'all data into array, headers included
MyData = Range("A1").CurrentRegion.Value

'clear range except headers
Range(Cells(2, 1), Cells(LastRow, LastColumn)).Clear

'Duplicate rows. Loop trough each row of array
'we start at row 2 because 1 is headers

HowManyCopies = 4 'as example, just 4 duplicates of each row
CurrentRow = 2 'where to start duplicating

For i = 2 To UBound(MyData) Step 1
    'loop trough counter until HowManyCopies is reached
    For MyCounter = 1 To HowManyCopies Step 1
        'loop trough each column and paste value
        For j = 1 To LastColumn Step 1
            Cells(CurrentRow, j).Value = MyData(i, j)
        Next j
        CurrentRow = CurrentRow + 1
    Next MyCounter
Next i

Erase MyData 'clean variable

Application.ScreenUpdating = True
End Sub
Run Code Online (Sandbox Code Playgroud)

在此输入图像描述

上面的示例只是将每行 5 行 4 列的数据集复制 4 次，但很容易适应 5000 行和 39 列（这将需要更长的时间，很难）。

更新：经过一些研究，我已经能够设计出更高效的代码，并使用 5000 行和 39 列的数据集进行测试，只需 55 秒即可完成。代码虽然较长，但毫无价值。

所有学分均归于以下资源：

如何在 Excel VBA 中对数组进行切片？

VBA 数组的 CPearson 函数

主子几乎相同，但代码更长，因为它需要一些辅助函数才能正常工作（检查 CPearson 链接以正确理解代码的作用）：

Option Explicit

'Source: http://www.cpearson.com/excel/vbaarrays.htm

' Error Number Constants
'''''''''''''''''''''''''''
Public Const C_ERR_NO_ERROR = 0&
Public Const C_ERR_SUBSCRIPT_OUT_OF_RANGE = 9&
Public Const C_ERR_ARRAY_IS_FIXED_OR_LOCKED = 10&

Sub test()
Dim Inicio As Date 'just to check how long, not needed
Inicio = Now 'just to check how long, not needed`

Dim i As Long, j As Long
Dim LastColumn As Long, LastRow As Long
Dim MyData As Variant, ThisDataRow() As Variant
Dim HowManyCopies As Long, MyCounter As Long, CurrentRow As Long

Application.ScreenUpdating = False

'get last column, in your case 39
LastColumn = 39

'get last non blank row, tested with 5000 rows of data
LastRow = Range("A" & Rows.Count).End(xlUp).Row

'all data into array, headers included
MyData = Range("A1").CurrentRegion.Value

'clear range except headers
Range(Cells(2, 1), Cells(LastRow, LastColumn)).Clear

'Duplicate rows. Loop trough each row of array
'we start at row 2 because 1 is headers

HowManyCopies = 58 '58 copies of each row, 57+1 because we delete original one
CurrentRow = 2 'where to start duplicating

For i = 2 To UBound(MyData) Step 1
    'loop trough counter until HowManyCopies is reached
    For MyCounter = 1 To HowManyCopies Step 1
        'paste values into row using CPearson codes
        GetRow MyData, ThisDataRow, i
        Range(Cells(CurrentRow, 1), Cells(CurrentRow, LastColumn)).Value = ThisDataRow
        CurrentRow = CurrentRow + 1
    Next MyCounter
Next i

Erase MyData 'clean variable
Erase ThisDataRow

Application.ScreenUpdating = True

Debug.Print Format(Now - Inicio, "hh:nn:ss") 'just to check how long, not needed

End Sub

Function GetRow(Arr As Variant, ResultArr As Variant, RowNumber As Long) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetRow
' This populates ResultArr with a one-dimensional array that is the
' specified row of Arr. The existing contents of ResultArr are
' destroyed. ResultArr must be a dynamic array.
' Returns True or False indicating success.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim ColNdx As Long
''''''''''''''''''''''''''''''
' Ensure Arr is an array.
''''''''''''''''''''''''''''''
If IsArray(Arr) = False Then
    GetRow = False
    Exit Function
End If

''''''''''''''''''''''''''''''''''
' Ensure Arr is a two-dimensional
' array.
''''''''''''''''''''''''''''''''''
If NumberOfArrayDimensions(Arr) <> 2 Then
    GetRow = False
    Exit Function
End If

''''''''''''''''''''''''''''''''''
' Ensure ResultArr is a dynamic
' array.
''''''''''''''''''''''''''''''''''
If IsArrayDynamic(ResultArr) = False Then
    GetRow = False
    Exit Function
End If

''''''''''''''''''''''''''''''''''''
' Ensure ColumnNumber is less than
' or equal to the number of columns.
''''''''''''''''''''''''''''''''''''
If UBound(Arr, 1) < RowNumber Then
    GetRow = False
    Exit Function
End If
If LBound(Arr, 1) > RowNumber Then
    GetRow = False
    Exit Function
End If

Erase ResultArr
ReDim ResultArr(LBound(Arr, 2) To UBound(Arr, 2))
For ColNdx = LBound(ResultArr) To UBound(ResultArr)
    ResultArr(ColNdx) = Arr(RowNumber, ColNdx)
Next ColNdx

GetRow = True


End Function

Public Function NumberOfArrayDimensions(Arr As Variant) As Integer
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' NumberOfArrayDimensions
' This function returns the number of dimensions of an array. An unallocated dynamic array
' has 0 dimensions. This condition can also be tested with IsArrayEmpty.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Ndx As Integer
Dim Res As Integer
On Error Resume Next
' Loop, increasing the dimension index Ndx, until an error occurs.
' An error will occur when Ndx exceeds the number of dimension
' in the array. Return Ndx - 1.
Do
    Ndx = Ndx + 1
    Res = UBound(Arr, Ndx)
Loop Until Err.Number <> 0

NumberOfArrayDimensions = Ndx - 1

End Function

Public Function IsArrayDynamic(ByRef Arr As Variant) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' IsArrayDynamic
' This function returns TRUE or FALSE indicating whether Arr is a dynamic array.
' Note that if you attempt to ReDim a static array in the same procedure in which it is
' declared, you'll get a compiler error and your code won't run at all.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim LUBound As Long

' If we weren't passed an array, get out now with a FALSE result
If IsArray(Arr) = False Then
    IsArrayDynamic = False
    Exit Function
End If

' If the array is empty, it hasn't been allocated yet, so we know
' it must be a dynamic array.
If IsArrayEmpty(Arr:=Arr) = True Then
    IsArrayDynamic = True
    Exit Function
End If

' Save the UBound of Arr.
' This value will be used to restore the original UBound if Arr
' is a single-dimensional dynamic array. Unused if Arr is multi-dimensional,
' or if Arr is a static array.
LUBound = UBound(Arr)

On Error Resume Next
Err.Clear

' Attempt to increase the UBound of Arr and test the value of Err.Number.
' If Arr is a static array, either single- or multi-dimensional, we'll get a
' C_ERR_ARRAY_IS_FIXED_OR_LOCKED error. In this case, return FALSE.
'
' If Arr is a single-dimensional dynamic array, we'll get C_ERR_NO_ERROR error.
'
' If Arr is a multi-dimensional dynamic array, we'll get a
' C_ERR_SUBSCRIPT_OUT_OF_RANGE error.
'
' For either C_NO_ERROR or C_ERR_SUBSCRIPT_OUT_OF_RANGE, return TRUE.
' For C_ERR_ARRAY_IS_FIXED_OR_LOCKED, return FALSE.

ReDim Preserve Arr(LBound(Arr) To LUBound + 1)

Select Case Err.Number
    Case C_ERR_NO_ERROR
        ' We successfully increased the UBound of Arr.
        ' Do a ReDim Preserve to restore the original UBound.
        ReDim Preserve Arr(LBound(Arr) To LUBound)
        IsArrayDynamic = True
    Case C_ERR_SUBSCRIPT_OUT_OF_RANGE
        ' Arr is a multi-dimensional dynamic array.
        ' Return True.
        IsArrayDynamic = True
    Case C_ERR_ARRAY_IS_FIXED_OR_LOCKED
        ' Arr is a static single- or multi-dimensional array.
        ' Return False
        IsArrayDynamic = False
    Case Else
        ' We should never get here.
        ' Some unexpected error occurred. Be safe and return False.
        IsArrayDynamic = False
End Select

End Function

Public Function IsArrayEmpty(Arr As Variant) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' IsArrayEmpty
' This function tests whether the array is empty (unallocated). Returns TRUE or FALSE.
'
' The VBA IsArray function indicates whether a variable is an array, but it does not
' distinguish between allocated and unallocated arrays. It will return TRUE for both
' allocated and unallocated arrays. This function tests whether the array has actually
' been allocated.
'
' This function is really the reverse of IsArrayAllocated.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim LB As Long
Dim UB As Long

Err.Clear
On Error Resume Next
If IsArray(Arr) = False Then
    ' we weren't passed an array, return True
    IsArrayEmpty = True
End If

' Attempt to get the UBound of the array. If the array is
' unallocated, an error will occur.
UB = UBound(Arr, 1)
If (Err.Number <> 0) Then
    IsArrayEmpty = True
Else
    ''''''''''''''''''''''''''''''''''''''''''
    ' On rare occassion, under circumstances I
    ' cannot reliably replictate, Err.Number
    ' will be 0 for an unallocated, empty array.
    ' On these occassions, LBound is 0 and
    ' UBoung is -1.
    ' To accomodate the weird behavior, test to
    ' see if LB > UB. If so, the array is not
    ' allocated.
    ''''''''''''''''''''''''''''''''''''''''''
    Err.Clear
    LB = LBound(Arr)
    If LB > UB Then
        IsArrayEmpty = True
    Else
        IsArrayEmpty = False
    End If
End If

End Function
Run Code Online (Sandbox Code Playgroud)

这是测试：

在此输入图像描述

只用了55秒。

Fan*_*uru 5

请尝试这种更紧凑的方式：

Sub duplicateRows()
  Dim sh As Worksheet, i As Long
  Const duplRows As Long = 57 'number of rows to be inserted
  
  Set sh = ActiveSheet: i = 2 '1 is for the header
  Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
  Do While sh.Range("A" & i) <> ""
       sh.rows(i + 1 & ":" & i + duplRows).insert xlDown
       sh.rows(i + 1 & ":" & i + duplRows).Value2 = sh.rows(i).Value2
      
      i = i + duplRows + 1
  Loop
  Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End Sub
Run Code Online (Sandbox Code Playgroud)

更快一点的版本（仅复制使用的范围数据）将是：

Sub duplicateRows_()
  Dim sh As Worksheet, lastr As Long, rngUR As Range, i As Long
  Const duplRows As Long = 3
  
  Set sh = ActiveSheet: i = 2 '1 is for the header
  Set rngUR = sh.UsedRange
  Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
  Do While sh.Range("A" & i) <> ""
       sh.rows(i + 1 & ":" & i + duplRows).insert xlDown
       Intersect(sh.rows(i + 1 & ":" & i + duplRows), rngUR.EntireColumn).Value2 = Intersect(sh.rows(i), rngUR).Value2
      
      i = i + duplRows + 1
  Loop
  Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End Sub
Run Code Online (Sandbox Code Playgroud)

最快的版本将是下一个。它（暂时）返回到下一张纸中，因此请注意留空。如果您喜欢返回，您可以删除活动工作表的现有内容并粘贴到那里。它使用第二个数组并将必要的数据放入其中，并在代码末尾立即删除处理后的结果。正如我在下面的评论之一中所建议的......：

Sub duplicateRowsArrays()
  Dim sh As Worksheet, sh1 As Worksheet, arrUR, arrFin, i As Long, j As Long, k As Long, c As Long
  Const duplRows As Long = 3
  
  Set sh = ActiveSheet: Set sh1 = sh.Next 'the sheet where to (temporarily) return the processed array result
  arrUR = sh.UsedRange.Value
  ReDim arrFin(1 To UBound(arrUR) * (duplRows + 1) + 1, 1 To UBound(arrUR, 2))
  
  For i = 1 To UBound(arrUR, 2): arrFin(1, i) = arrUR(1, i): Next i 'place the header in final array
  k = 2
  For i = 2 To UBound(arrUR)                  'starting iteration from the second row
        For j = 1 To duplRows + 1             'place the necessary data in the virtually inserted rows
            For c = 1 To UBound(arrUR, 2)
              arrFin(k, c) = arrUR(i, c)
            Next c
            k = k + 1
        Next j
  Next i
  
  'drop the final array content at once:
   sh1.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2)).Value = arrFin
End Sub
Run Code Online (Sandbox Code Playgroud)

如果您喜欢这个结果，您应该清除sh.cells并将结果放在sh.Range("A1")...

归档时间：

查看次数：

298 次

最近记录：

2 年，5 月 前
如何在Excel VBA中切片数组？ 27
更多相关链接
相关归档
使用默认程序打开Excel文件 11
Excel:打开.csv文件时,默认为TEXT而不是GENERAL 10
如何使用Apache POI选择并加粗整个工作表 10
VBA,如果字符串包含某个字母 9
Workbook_Open后焦点错误的Excel窗口 6
如何使用 VBA 与其他 Office 用户共享 Excel 文件？ 6
使用vba检查网络连接 4
寻找合并细胞的边界？ 2
直到_____,直到_____循环 1
尝试删除工作簿中的所有工作表,然后使用VBA添加其他工作表 1
难疑归档
"px","dip","dp"和"sp"之间有什么区别？ 5676
如何从异步调用返回响应？ 5208
如何在Python中安全地创建嵌套目录？ 3909
在'for'循环中访问索引？ 3312
如何制作一个很好的R可重复的例子 2474
ListView中的图像延迟加载 1881
表命名困境:奇异与多个名称 1404
int32的最大值是多少？ 1383
使用*args和**kwargs 1367
如何删除选择框的所有选项,然后添加一个选项并使用jQuery选择它？ 1028