Как дублировать строки

Я хочу дублировать каждую строку на листе 57 раз на строку в 39 столбцах (после результата, что означает, что будет 58 дубликатов каждой записи).

Так, например, я включил ниже фрагмент того, как некоторые из моих записей выглядят сейчас (имейте в виду, что есть 39 столбцов, фрагмент не может вырезать полное представление):

И вот результат, который я ищу для foR (Примечание: в этом примере 10 дубликатов для каждой строки, а не 58, так как снимок экрана был бы слишком большим). Исходный файл содержит более 5000 записей, поэтому я знаю, что какой бы код я ни использовал, загрузка займет некоторое время, меня это устраивает, мне просто нужен результат)

Вот код, который я использовал ниже, он не дублирует строки как таковые, но гарантирует, что каждая строка имеет промежуток в 57 пустых строк между каждой строкой в ​​39 столбцах (от A до AM). Это был бы более долгий и сложный способ выполнения задачи, так как тогда мне пришлось бы найти способ заполнить пробелы. Поэтому я задаю вопрос, поскольку должен быть более эффективный способ.

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

Пожалуйста, дайте мне знать, что вы думаете, извините, если есть гораздо более простое решение, о котором я в настоящее время не знаю. Я пытался искать на форумах и другие вопросы, но ни один код, который я отображал, не дал мне результата в желаемом направлении.

Спасибо

Вы можете прочитать о методе Excel Range.insert

freeflow 20.02.2023 12:23

@freeflow, использующий код Range("3:3").Insert CopyOrigin:=xlFormatFromLeftOrAbove и дублирующий 57, действительно создает 57 пустых строк, но он не применяется ко всем записям и не дублируется, поэтому этот метод не кажется правильным.

EuanM28 20.02.2023 12:49
Преобразование HTML-таблицы в профессиональный документ Excel
Преобразование HTML-таблицы в профессиональный документ Excel
Это самый простой способ создания Excel из HTML-таблицы.
Импорт excel в laravel в базу данных
Импорт excel в laravel в базу данных
Здравствуйте, дорогой читатель, в этой статье я расскажу практическим и быстрым способом, как импортировать файл Excel в вашу базу данных с помощью...
3
2
121
4
Перейти к ответу Данный вопрос помечен как решенный

Ответы 4

Ответ принят как подходящий

Вы можете взять все данные в массив и вставить значения оттуда в цикле:

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

В приведенном выше примере просто дублируется набор данных из 5 строк и 4 столбцов в каждой строке 4 раза, но его легко адаптировать к 5000 строк и 39 столбцов (это займет больше времени, сложно).

ОБНОВЛЕНИЕ. Проведя небольшое исследование, я смог разработать более эффективный код и протестировать его с набором данных из 5000 строк и 39 столбцов, на выполнение которого ушло всего 55 секунд. Код длиннее, но он бесполезен.

Все кредиты идут на эти ресурсы:

Как нарезать массив в Excel VBA?

Функции CPearson для VBA Массивы

Основной саб почти такой же, но код длиннее, потому что для правильной работы ему нужны некоторые вспомогательные функции (проверьте ссылку 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

Вот тест:

Заняло всего 55 секунд.

Это качество, именно то, что мне было нужно, вы чемпион

EuanM28 20.02.2023 12:54

Запуск занимает всего 6 минут, что приводит к 301 659 строкам, класс

EuanM28 20.02.2023 13:05

@ EuanM28 Пожалуйста, проверьте обновленный ответ и посмотрите, не займет ли это меньше времени. Спасибо!!!

Foxfire And Burns And Burns 21.02.2023 11:05

У меня это заняло 4 минуты 35 секунд, но я столкнулся с множеством странных прогонов с VBA (иногда что-то, что занимает 1 минуту, занимает 5 в выходные дни с таким же объемом данных). В любом случае, это быстрее, так что спасибо! Я уверен, что в будущем он будет работать быстрее. Еще раз спасибо, это очень помогло.

EuanM28 21.02.2023 11:39

Попробуйте этот более компактный способ, пожалуйста:

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

И немного более быстрая версия (копирование только используемых данных диапазона) будет:

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

Самая быстрая версия будет следующей. Он (временно) возвращается на следующем листе, поэтому позаботьтесь о том, чтобы он был пустым. Если вам нравится возврат, вы можете удалить существующее содержимое активного листа и вставить его туда. Он использует второй массив и размещает в нем нужные данные, отбрасывая обработанный результат сразу, в конце кода. Как я предложил в одном из моих комментариев ниже...:

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

Если вам нравится результат, вы должны очистить sh.cells и перетащить результат на sh.Range("A1")...

Проголосовал за этот код, потому что этот код действительно очень короткий и при необходимости сохраняет исходный формат, но это занимает больше времени, чем работа с массивами.

Foxfire And Burns And Burns 20.02.2023 13:23

@Foxfire И Бернс и Бернс Спасибо! Я бы сказал, это зависит от размера обрабатываемого диапазона, и это не так уж и медленно. Он не использует буфер обмена, сохраняя формат от вставки. Копирование в ячейку из массива занимает больше времени, чем массив в массив (среднее .value в .value). Код можно легко адаптировать для использования пересечения между используемым диапазоном и копируемыми/вставляемыми строками. Действительно быстрым решением было бы также удалить значения в массиве. Легко ReDim создать такой массив с самого начала и загрузить его в простой итерации.

FaneDuru 20.02.2023 13:36

@Foxfire And Burns And Burns Наибольшая экономия времени будет получена при записи в ячейках только один раз, в конце кода. Я проложил более быстрый путь, используя вышеупомянутый перекресток.

FaneDuru 20.02.2023 13:37

Протестировано с набором данных 20x39, 100 дубликатов каждой строки. Работа с массивами занимает 2,31E-05, а работа с Insert — 6,02E-04 Почти в 26 раз медленнее. Я использую Эксель 2007.

Foxfire And Burns And Burns 20.02.2023 14:10

@Foxfire And Burns And Burns Очевидно, что вставка строк занимает много времени ... Меня сейчас нет рядом с моим компьютером. Когда я буду рядом с ним, я попробую написать кусок кода в другом массиве и сразу сброшу обработанный результат. Это должен быть более быстрый способ, я думаю...

FaneDuru 20.02.2023 14:17

Просто из любопытства, можете ли вы попробовать это и сообщить мне, сколько времени это займет? Я думаю, что это может быть быстрее, чем решение Foxfire, поскольку оно записывает не в отдельные ячейки, а в массив, а затем просто присваивает этот массив диапазону.

Также, пожалуйста, выберите лист, с которым вы хотите работать, потому что у меня были очень странные ошибки при указании рабочего листа в некоторых строках, поэтому я просто избавился от него.

Sub dupeRows()
    Dim arr() As Variant, resultArr() As Variant, rng As Range, dupeCount As Long, lastRow As Long, lastColumn As Long
    
    dupeCount = 58 'specify number of duplicates here
    
    With ActiveSheet
        lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
    
    Set rng = Range(Cells(2, 1), Cells(lastRow, lastColumn))
    
    arr = rng
    ReDim resultArr(1 To (UBound(arr) * dupeCount), 1 To UBound(arr, 2))
    
    For i = 1 To UBound(arr)
        For k = 1 To dupeCount
            For j = 1 To UBound(arr, 2)
                resultArr((i - 1) * dupeCount + k, j) = arr(i, j)
            Next j
        Next k
    Next i
    Application.ScreenUpdating = False 'this probably doesn't really help in my case
        Range(Cells(2, 1), Cells(lastRow * dupeCount - dupeCount + 1, lastColumn)) = resultArr
    Application.ScreenUpdating = True
End Sub

На моем компьютере (Windows 10, Excel 2010, 8 ГБ встроенной памяти) и со значениями в диапазоне A2: AM1001 (= 1000 строк, что должно быть 58000 строк, заканчивающихся строкой 58001 после запуска макроса), я провел тест с 5 макросов выше (каждый макрос 3 раза тестируется каждый раз, когда создается новый файл). Вот результаты:

  1. Foxfire And Burns And Burns: дополнительный тест () --> Продолжительность: 57, 53 и 55 секунд. Результат: ок.

  2. FaneDuru: Субдубликаты строк () --> Через 6 минут макрос все еще работал, и я остановил его вручную. На тот момент было скопировано 80 (из 1000) строк (x 57).

  3. FaneDuru: Вложенные дубликаты_() --> Макрос пришел с ошибкой в ​​этой строке: "Intersect(…." Ошибка: «Переменная объекта или блока With не задана»

  4. FaneDuru: субдубликатыRowsArrays() --> Этот макрос абсолютно ничего не делал.

  5. andrewB: Sub dupeRows() Макрос останавливается через несколько секунд. Только столбец A имеет правильные значения, другие столбцы - нет (они не изменились).

Я сам написал макрос ниже и на моем компьютере он дает правильный результат за 30 секунд, но я знаю, что есть более быстрые способы. Допущение: данные находятся на листе с именем «Лист1», при необходимости скорректируйте.

Sub Copy_Insert()
Dim x As Long
With Sheets("Sheet1")
x = .Range("a" & .Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Do Until x = 1
.Rows(x).Copy
.Rows(x & ":" & x + 56).EntireRow.Insert
x = x - 1
Loop
Application.CutCopyMode = False
Application.ScreenUpdating = True
End With
End Sub

Вы поняли, что третья версия возвращается в следующем листе? Вы там смотрели? Я протестировал его и работал как надо. Во второй версии была ошибка, исправил с помощью rngUR.EntireColumn).Value2...

FaneDuru 20.02.2023 19:37

Я понимаю; макрос очень быстрый, но работает не так как надо. Первая строка копируется только один раз, и копии должны начинаться со строки 2. Я думаю, это легко исправить.

alpha 20.02.2023 20:33

Что значит "быстро"? Вы представили некоторые промежутки времени в своем «анализе»... Зачем вам нужно/хотите копировать заголовок более одного раза? На основании чего вы оцениваете, что "работает не так, как надо"?

FaneDuru 20.02.2023 20:42

Я не хочу, чтобы заголовок копировался! Но когда вы посмотрите на изображение ts здесь, вы увидите, что первой копируемой строкой является строка 2 со значениями row1 - row1 - row1 - и т. д. Эту строку вы копируете только один раз! «Что значит «быстро»? Я имею в виду: быстро, по сравнению с другими «решениями» в этой теме.

alpha 20.02.2023 20:59

Я не знаю, как вы его тестировали. Вставка начинается со второй строки включительно. Может быть, у вас есть какие-то скрытые строки или что-то, что я не могу проверить. А я думал, что и "быстро" надо переводить так же. Я имею в виду, сколько минут, секунд...

FaneDuru 20.02.2023 21:06

В моем первом посте я объяснил, как я тестировал макрос! У меня нет скрытых строк, и с моим Excel 2010 все в порядке. Каждый тест я начинал с нового файла. Чтобы иметь возможность правильно сравнивать, макрос должен давать правильное решение, а ваш макрос этого не делает (первая строка с данными копируется только 1 раз вместо 57 раз). Я говорил тебе это дважды, и это третий и последний раз. Попросите других протестировать ваш макрос (я это сделал!), и они придут к такому же выводу. Для меня нет смысла обсуждать это дальше.

alpha 20.02.2023 21:56

Я подозреваю, что мой макрос работал только для одного столбца, потому что у вас не было значений в первой строке, это правильно? Sub определяет количество столбцов, проверяя последнюю ячейку с данными в первой строке. Кстати, спасибо за это!

andrewb 21.02.2023 03:57

Другие вопросы по теме