匹配范围内的值，复制并将数据插入其他工作表

Question

我有大约50张包含数据和1张主表格，其中包含可以匹配50张中任意一张的更新数据列。

如果范围B2：Z2（MasterSheet）中的值与工作簿中某个工作表中B2：H2中的值匹配，则将（MasterSheet）中匹配单元格下的所有数据复制并插入到包含的工作表中匹配单元格下方的匹配值，不覆盖数据。

包含更新数据的主题表

匹配Sheet10中的值，从MasterSheet插入数据而不覆盖现有数据（紫色文本）

我尝试了以下代码，但收到了错误。

Sub InsertUpdatedMeasurement()
  Dim sRange As Range, Rng As Range, WS As Worksheet, FindString As String
  FindString = Sheets("MasterSheet").Range("B2:Z2").Value

  For Each WS In ActiveWorkbook.Worksheets        
    LastRow = Sheets("MasterSheet").Range(Rows.Count,"B2:Z2").End(xlUp).Row.Offset(,1)

    If WS.Name <> "MasterSheet" Then
      WS.Activate

      LastRow2 = ActiveSheet.Range(Range.Count "B2:Z2").End(xlUp).Row.Offset(,1)
      Set sRange = ActiveSheet.Range("B2:Z2" & LastRow2)

      With sRange
        Set Rng = .Find(What:=FindString, _ 
          After:=.Cells(1), _
          LookIn:=xlValues, _ 
          LookAt:=xlWhole, _ 
          SearchOrder:=xlByRows, _
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False)         

        If Not Rng Is Nothing Then
          Rng.Copy       
          ActiveSheet.Rows(Rng).Selection.Insert.Shift:=xlDown     
          Application.CutCopyMode = False
          LastRow1 = LastRow1 + 1        
        End If
      End With
    End If       
  Next Ws

  Sheets("MasterSheet").Activate
  Application.ScreenUpdating = True    
End Sub

Answer 1

如果不重写整个代码，很难给出一个好的答案。希望这会让你超越错误。

替换这些行

  

LastRow2 = ActiveSheet.Range（Range.Count＆＃34; B2：Z2＆＃34;）。End（xlUp）.Row.Offset（，1）

     

设置sRange = ActiveSheet.Range（＆＃34; B2：Z2＆＃34;＆amp; LastRow2）

使用此行

  

设置sRange =范围（＆＃34; B2：Z2＆＃34;，范围（＆＃34; B＆＃34;＆amp; Rows.Count）.End（xlUp））。偏移（，1）

您似乎正在尝试复制Rng。

Rng.Copy
ActiveSheet.Rows(Rng).Selection.Insert.Shift:=xlDown

Application.CutCopyMode = False

这会将范围向下移动

  

Rng.Insert.Shift：= xlDown，CopyOrigin：= xlFormatFromLeftOrAbove