Скопируйте и вставьте строки, которые соответствуют условию, в другую рабочую книгу одновременно - PullRequest
Новая
       25

Скопируйте и вставьте строки, которые соответствуют условию, в другую рабочую книгу одновременно

0 голосов
/ 23 мая 2018

Мне нужно было бы пройти строки из masterfile (thisworkbook) в разные рабочие книги на основе id.Проблема, с которой я сейчас сталкиваюсь в своем коде, заключается в том, что копировать и вставлять все строки по одной слишком медленно, поскольку мастер-файл довольно большой, и я хотел бы добавить больше условий (и рабочих книг) в мой код впоследствии.

Мой текущий код, копирование и вставка строк одна за другой, когда выполняется условие: 

Private Sub CommandButton2_Click()
    a = Worksheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row
    Dim newWorkbookOne As Workbook, newWorkbookTwo As Workbook
    Set newWorkbookOne = Workbooks.Add
    Set newWorkbookTwo = Workbooks.Add
    Dim conditionOne As String, conditionTwo as String
    Set conditionOne = "value1"
    Set conditionTwo = "value2"
    For i = 2 To a
        If ThisWorkbook.Worksheets("Sheet1").Cells(i, 1).Value = conditionOne Then
        ThisWorkbook.Worksheets("Sheet1").Rows(i).Copy
        b = newWorkbookOne.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        newWorkbookOne.ActiveSheet.Cells(b + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
    End If
    If ThisWorkbook.Worksheets("Sheet1").Cells(i, 1).Value = nametwo Then
        ThisWorkbook.Worksheets("Sheet1").Rows(i).Copy
        h = newWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        newWorkbookTwo.ActiveSheet.Cells(h + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats

    End If
  Next 'something

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

Ответы [ 2 ]

0 голосов
/ 23 мая 2018

Для начала убедитесь, что ScreenUpdating отключено следующим образом: 

Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
    a = Worksheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row
    Dim newWorkbookOne As Workbook, newWorkbookTwo As Workbook
    Set newWorkbookOne = Workbooks.Add
    Set newWorkbookTwo = Workbooks.Add
    Dim conditionOne As String, conditionTwo as String
    Set conditionOne = "value1"
    Set conditionTwo = "value2"
    For i = 2 To a
        If ThisWorkbook.Worksheets("Sheet1").Cells(i, 1).Value = conditionOne Then
        ThisWorkbook.Worksheets("Sheet1").Rows(i).Copy
        b = newWorkbookOne.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        newWorkbookOne.ActiveSheet.Cells(b + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
    End If
    If ThisWorkbook.Worksheets("Sheet1").Cells(i, 1).Value = nametwo Then
        ThisWorkbook.Worksheets("Sheet1").Rows(i).Copy
        h = newWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        newWorkbookTwo.ActiveSheet.Cells(h + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats

    End If
  Next 'something
  Application.ScreenUpdating = True

Это должно значительно сократить потребление времени.

Кроме того, если вы хотите сделать это по-другому, вы можете попробовать выполнить первый оператор If и скрыть все строки, которые вы не хотите копировать.Затем скопируйте и вставьте все видимые строки в соответствующем диапазоне за один раз.Затем откройте их и запустите второе утверждение If таким же образом.
Попробуйте сами, и дайте мне знать, если вам нужна помощь:)

0 голосов
/ 23 мая 2018

1) Установить Application.ScreenUpdating = False

2) Вы можете вставить все строки в массив вместо того, чтобы копировать строки по одной, а затем вставлять их все сразу после завершения цикла.Это вставка, которая занимает время, а не столько копирование.

Попробуйте: 

Dim newWorkbookOne As Workbook, newWorkbookTwo As Workbook
Dim conditionOne As String, conditionTwo as String
Dim arr1 (0 to 999) as Variant ' change parameters as required
Dim arr2 (0 to 999) as Variant ' change parameters as required
Dim j as Integer, n as Integer

a = Worksheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row
Set newWorkbookOne = Workbooks.Add
Set newWorkbookTwo = Workbooks.Add

Set conditionOne = "value1"
Set conditionTwo = "value2"
For i = 2 To a
    If ThisWorkbook.Worksheets("Sheet1").Cells(i, 1).Value = conditionOne Then
    arr(j) = ThisWorkbook.Worksheets("Sheet1").Rows(i)
    j = j + 1
End If
If ThisWorkbook.Worksheets("Sheet1").Cells(i, 1).Value = nametwo Then
    arr2(n) = ThisWorkbook.Worksheets("Sheet1").Rows(i)
    n = n + 1
End If
Next 'something

' Insert the values of the arrays in the two new worksheets here

Правка №1: вставка значений массива 

lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row ' change sheet to what's appropriate

For i = LBound(arr) To UBound(arr)
    Rows(lastRow + 1 + i).Value2 = arr(i) ' presupposes the array starts at index 0
Next i
...