Блог

Я несколько раз искал решение для использования .PasteSpecial в макросе excel vba. У меня есть отчеты, которые иногда могут содержать тысячи строк. В этих отчетах два столбца, мне нужно объединить эти столбцы, чтобы, если в одном столбце есть пробелы, я хотел бы получить значение из второго столбца; в противном случае просто сохраните значение в первом столбце. Мне нужно применить это дважды в двух разных местах. Все это вложено в более крупный код.

Мое решение-использовать .PasteSpecial с «Пропуском заготовок». Это быстро обрабатывается Excel, намного быстрее, чем циклическое выполнение строки за строкой. Проблема в том, что код продолжает выводить excel из строя.

После отладки вот что я узнал до сих пор: *Первый .PasteSpecial всегда работает, но когда дело доходит до второго .По-особому это всегда терпит неудачу. *Я попробовал ОСТАНОВИТЬСЯ после первого .PasteSpecial, затем пройти через код, а затем пройти через второй.Специальный код работает просто отлично. *Если я пройду через второй .В прошлом это работает так, как будто ничего не случилось, но если я просто запущу код как обычно, он выйдет из строя. *Я поменял порядок двух .PasteSpecials в коде. Когда я это делаю, он больше не падает на проблемном .Специальная паста, но она выходит из строя на первоначально работающем .специальная паста.

Исходя из этого, я знаю, что проблема в том, что Excel это не нравится .Специальная вставка дважды в коде. Все еще не могу найти обходной путь. Я попытался очистить доску для клипов, и я недостаточно знаю, как настроить массив, не говоря уже о том, эффективно ли это для такого количества данных. Кто — нибудь знает решение или обходной путь?

Вот мой .специальный код.:

 MainSheet.Range("N:N").Copy
MainSheet.Range("P:P").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=True, Transpose:=False

MainSheet.Range("R:R").Copy
MainSheet.Range("Q:Q").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
 

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

В ячейках есть значения… так сделай их равными и они… будет… быть…

 Range("C1").Value = Range("A1").Value
 

В качестве альтернативы вы можете использовать запрос мощности, чтобы просто сделать это, где таблица 2 Col2 равна нулю, а ID = ID

Не нуждаясь в формате, пожалуйста, протестируйте следующий код. Он использует массив, а не буфер обмена и работает быстрее. Если нет необходимости в существовании соответствия между строками в двух заполненных столбцах, вы можете воспользоваться следующим быстрым способом:

 Sub copyColumnsArray()
 Dim lastR As Long, arrCopy, arrFin, i As Long, k As Long
 
 lastR = MainSheet.Range("N" amp; rows.count).End(xlUp).row
 arr = MainSheet.Range("N1:N" amp; lastR).value
 
 'fill another array only with non empty values:__________________
 ReDim arrFin(UBound(arr) To 1): k = 1
 For i = 1 To UBound(arrCopy)
    If arrCopy(i, 1) <> "" Then arrFin(k, 1) = arrCopy(i, 1): k = k   1
 Next i
 ReDim Preserve arrFin(k - 1 To 1)
 '______________________________________________________
 
 MainSheet.Range("P1").Resize(UBound(arrFin), 1).value = arrFin
 
 lastR = MainSheet.Range("R" amp; rows.count).End(xlUp).row
 arr = MainSheet.Range("R1:R" amp; lastR).value
 
 'fill another array only with non empty values:__________________
 ReDim arrFin(UBound(arr) To 1): k = 1
 For i = 1 To UBound(arrCopy)
    If arrCopy(i, 1) <> "" Then arrFin(k, 1) = arrCopy(i, 1): k = k   1
 Next i
 ReDim Preserve arrFin(k - 1 To 1)
 '______________________________________________________
 
 MainSheet.Range("Q1").Resize(UBound(arrFin), 1).value = arrFin
End Sub
 

Редактировать:

Лучший ответ, который работал более надежно, чем мое оригинальное найденное решение, приведен ниже. Это адаптация некоторых советов из ответа ФанеДуру. Это решение более требовательно к ресурсам; однако на данный момент — оно выполняет задачу надежно (без сбоев). Я бы хотел, чтобы были лучшие ответы, чем циклическое повторение строк; однако это действительно отвечает на мою операцию. Спасибо вам за всю помощь!

     Sub copyColumnsArray()
 Dim lastR As Long, arrCopy
 
 lastR = MainSheet.Range("N" amp; rows.count).End(xlUp).row
 arrCopy = MainSheet.Range("N1:N" amp; lastR).value 

Dim ArrayIndex as Variant
Dim RowCount as String
RowCount = 1

For Each ArrayIndex in arrCopy
  If ArrayIndex = "" then
    RowCount = RowCount  1
    'Skip Blank
   else
    MainSheet.Range("P" RowCount).value = ArrayIndex
    RowCount = RowCount   1
   end if
 Next
 

 lastR = MainSheet.Range("R" amp; rows.count).End(xlUp).row
 arrCopy = MainSheet.Range("R1:R" amp; lastR).value

RowCount = 1

For Each ArrayIndex in arrCopy
  If ArrayIndex = "" then
    RowCount = RowCount  1
    'Skip Blank
   else
    MainSheet.Range("Q" RowCount).value = ArrayIndex
    RowCount = RowCount   1
   end if
 Next

End Sub