Excel VBA Поиск нескольких листов и вставка выбранных строк в итоговый рабочий лист

В настоящее время я пытаюсь сканировать столбцы D & K в нескольких листах (число может меняться). Если значение в столбце D равно 9 или 10, или если значение в столбце K> 100, я хочу скопировать всю строку в итоговый лист. Он создает сводную таблицу, но не копирует все строки. Вот что у меня есть до сих пор:Excel VBA Поиск нескольких листов и вставка выбранных строк в итоговый рабочий лист

Option Explicit 

Sub AppendDataAfterLastColumn() 
Dim sh As Worksheet 
Dim DestSh As Worksheet 
Dim Last As Long 
Dim CopyRng As Range 
Dim SearchRng As Range 
Dim SearchRng1 As Range 
Dim rngCell As Range 
Dim lastrow As String 

With Application 
    .ScreenUpdating = False 
    .EnableEvents = False 
End With 

' Delete the summary worksheet if it exists. 
Application.DisplayAlerts = False 
On Error Resume Next 
ActiveWorkbook.Worksheets("Action Items").Delete 
On Error GoTo 0 
Application.DisplayAlerts = True 

' Add a worksheet with the name "Action Items" 
Set DestSh = ActiveWorkbook.Worksheets.Add 
DestSh.Name = "Action Items" 
Sheets("Action Items").Move Before:=Sheets(3) 

Sheets(4).Select 
Range("A1:U3").Select 
Selection.Copy 
Sheets("Action Items").Select 
Range("A1").Select 
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _ 
    SkipBlanks:=False, Transpose:=False 
ActiveSheet.Paste 
Range("a1") = "PFMEA Action Items" 

' Loop through all worksheets and copy the data to the 
' summary worksheet. 
For Each sh In ActiveWorkbook.Worksheets 

     If sh.Name <> DestSh.Name Then 

      Set SearchRng = ActiveSheet.Range("D:D, K:K") 

      ' Find the last row with data on the summary 
      ' worksheet. 
      Last = Worksheets("Action Items").UsedRange.Rows.Count 

       For Each rngCell In SearchRng.Cells 

        If rngCell.Value <> "" Then 

         If rngCell.Value = "9" Or "10" Then 
         'select the entire row 
          rngCell.EntireRow.Select 
          MsgBox Selection.Address(False, False) 
          Selection.Copy 

          ' This statement copies values, formats, and the column width. 

          lastrow = DestSh.Cells(Rows.Count, "A").End(xlUp).Row + 1 
          DestSh.Cells(lastrow, "A").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _ 
           SkipBlanks:=False, Transpose:=False 

         ElseIf rngCell.Value > 100 Then 

          'select the entire row 
          rngCell.EntireRow.Select 
          Selection.Copy 

          ' This statement copies values, formats, and the column width. 
          lastrow = DestSh.Cells(Rows.Count, "A").End(xlUp).Row + 1 
          DestSh.Cells(lastrow, "A").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _ 
           SkipBlanks:=False, Transpose:=False 

         End If 

        End If 

       Next rngCell 

     End If 
Next 

ExitTheSub: 

Application.Goto DestSh.Cells(1) 

With Application 
    .ScreenUpdating = True 
    .EnableEvents = True 
End With 
End Sub

Спасибо за помощь!

источник

2016-08-11 S. Graham

Одна из проблем, которые я замечаю, заключается в том, что в вашем выражении if: if rngCell.Value = "9" или "10" Тогда у вас нет вторых критериев. Замените «Если rngCell.Value =« 9 »или rngCell.Value =« 10 »Then'. Кроме того, рекомендуется избегать использования выборочных утверждений, когда это возможно. Просто запустите методы непосредственно на объектах. :) – PartyHatPanda

Спасибо за ввод. Я внес изменения, но ничего не изменил. Я думаю, что моя проблема связана с тем, как я выбираю, копирую, а потом вставляю. –

sh.Activate Добавить после If sh.Name <> DestSh.Name Then

Также рассмотреть комментарий, данного «PartyHatPanda»

источник

2016-08-11 14:23:14 Siva

Спасибо за ввод. Я сделал изменения, но, похоже, скопировал неправильные вещи, а затем дал ошибку с методом пасты (пастовый специальный метод класса диапазона не удался) –

Возможно, в этом случае я понял, что ваш вопрос не прав. То, что я стоял, вы пытаетесь проверить значение элементов sheet1-D или K-клеток для какого-либо условия, если условие выполнено, вы не можете скопировать всю строку, где выполняется условие, а затем скопировать ее в «Action Items» и он делает правильно, когда я пробовал ваш код, просто выполняя изменения, которые я предложил. – Siva

Вы поняли правильно. Я пробовал это на простых данных, и это сработало, как вы сказали. Я думаю, что моя проблема заключается в том, что данные связаны с таблицей, а некоторые из ячеек объединяются (по вертикали), и я получаю это сообщение «Здесь уже есть данные. Вы хотите его заменить?». Есть идеи? Спасибо –

Я думаю, что проблема здесь в вашей пасте специального кода, вы говорите это, чтобы вставить ширину столбцов. Я скопировал ваш код DestSh.Cells(lastrow, "A").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False, а затем я изменил его на DestSh.Cells(lastrow, "A").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False. Для меня он копирует строки и значения. Как вы его написали, вы можете получить дубликаты в зависимости от того, соответствуют ли значения в столбцах d и в столбцах k критериям. Если это нежелательно, вам может понадобиться либо сократить ряды, либо настроить дополнительные критерии для работы. Посмотрите, поможет ли это! :)

источник

2016-08-11 15:11:55 PartyHatPanda

Спасибо! Казалось, это немного помогло. –

Excel VBA Поиск нескольких листов и вставка выбранных строк в итоговый рабочий лист

ответ

Смежные вопросы