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语句中，如果rngCell.Value =“9”或者“10”那么你没有第二个标准。用'If rngCell.Value =“9或者rngCell.Value =”10“Then替换。另外，尽可能避免使用select语句是一种好的做法。只需在对象上直接运行方法。 :) – PartyHatPanda

感谢您的意见。我做了改变，但似乎没有改变任何东西。我认为我的问题与我选择，复制和粘贴的方式有关。 –

添加sh.Activate后If sh.Name <> DestSh.Name Then

还要考虑通过“PartyHatPanda”

来源

2016-08-11 14:23:14 Siva

感谢您的输入。我做了改变，但它似乎复制了错误的东西，然后给出了粘贴方法的错误（范围类别的pastespecial方法失败） –

可能是我理解你的问题在这种情况下是错误的。我的立场是，你试图检查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搜索多个工作表并将所选行粘贴到摘要工作表

回答

相关问题