查找一个工作表中的值在指定范围内的另一个

Question

意向

1. 这将包括11个相同的工作表（10对站点的数据输入特定区域正在开发中，并且1“掌门人”它收集总数）
2. 主工作表是开始日期改变的地方。当更改开始日期时，它会反映在10个数据输入工作表中。还有数字值表示开始日期有多远。
3. 更改开始日期时，这些值需要随开始日期一起移动（即，如果开始日期是1月5日并且数据输入工作表上已有数据，并且开始日期更改为1月7日，则全部所有工作表的数据将需要2移动到右）

拟过程

我能得到的前两个函数的工作，但是这是这是造成一些悲伤的最后一个。

我想到的是一个程序化的复制粘贴。当更改开始日期时，它将转到第一个数据录入工作表，并将当前标题设置复制到“传输”工作表，保留该工作表的原始日期设置。然后它会删除数据录入工作清单中的数据。

下一步是转到第一个数据输入工作表（后台代码名以“Sz”开头），将数据输入的第一个数值匹配到Transfer工作表，检索数据并粘贴列数据放入新的位置。

当它完成数据录入工作表时，它会清除“传输”工作表，移动到下一个数据录入工作表，然后重复该过程。

问题

不幸的是，我写的是说这是发现的数值，当数值不存在的代码。然后它有时会显示一条错误消息，指出“代码执行已被中断”。

我一直在加班工作了大约十五个小时，除此之外还有整整一周的时间。我搜索了无数的潜在解决方案，并尝试了很多解决方法，但正式处于死胡同。我主要通过其他人的例子教会了我自己，所以我不是Excel VBA的专家。

如果我能得到匹配的功能正常工作，我相信我应该能够处理其余的，但更有效的方法的建议是非常值得欢迎的。

我不用太多论坛，但我会尝试粘贴下面的代码。

请让我知道我可以提供什么其他信息。

编辑：以下是工作簿的示例。要运行该功能，您将需要对 “工厂” 工作表（SZ001）：Dropbox Link

代码：

Sub Test() 
Dim sh As Worksheet, flg As Boolean 

For Each sh In Worksheets 

'FUNCTIONAL: If sh.CodeName Like "Sz0*" Then 'flg = True 

If sh.CodeName = "Sz001" Then 'Isolating a single Worksheet for testing 

'Copy original values and location to Transfer Worksheet 
'DISABLED THIS SECTION WHILE TESTING 
'sh.Select 
'ActiveSheet.Range("H8:ABI460").Copy 
'Worksheets("Transfer").Select 
'ActiveSheet.Range("H8").PasteSpecial xlPasteValues 

'Begin Matching Loop -THIS IS WHERE THE ISSUES ARE HAPPENING 
Dim xlRange As Range 'Current sh Range 
Dim xlSheet As Worksheet 'Current sh Worksheet 
Dim xlCell As Range 'Cell function is currently looking at 
Dim x As Range 

Set xlSheet = sh 
Set xlRange = xlSheet.Range("H6:ABI6") 

For Each xlCell In xlRange 

    Set x = ActiveSheet.Cells.Find(what:=xlCell, after:=Worksheets("Transfer").Range("G6"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext) 

    If Not x Is Nothing Then 
     MsgBox Cells(xlCell.Row, xlCell.Column) & "Found" 
    Else 
     MsgBox Cells(xlCell.Row, xlCell.Column) & "Not Found" 
    End If 

Next xlCell 

End If 

Next 

End Sub 

Answer 1

测试：

Option Explicit 

Public Sub Test() 

    Const WS_TR  As String = "Transfer" 'Sheet Transfer 
    Const WS_RNG As String = "H6:ABI6" 'row 6 on both sheets 

    Dim wsSz As Worksheet, wsTr As Worksheet, cel As Range 
    Dim found As Range, row6Sz As Range, row6Tr As Range 

    Set wsSz = Sz001    'Code Name for the sheet "Sz001" 
    Set wsTr = Worksheets(WS_TR) 

    Set row6Sz = wsSz.Range(WS_RNG) 'searched values 
    Set row6Tr = wsTr.Range(WS_RNG) 'search area 

    For Each cel In row6Sz 'searched values 

     Set found = row6Tr.Find(what:=Val(cel.Value2), LookIn:=xlValues, _ 
           LookAt:=xlWhole, SearchFormat:=False, _ 
           SearchOrder:=xlByColumns, SearchDirection:=xlNext) 

     Debug.Print cel.Value2 & IIf(Not found Is Nothing, " Found", " Not Found") 

    Next 

End Sub 

。

注：

• 我更换了MSGBOX与Debug.Print
• 对于结果按按Ctrl +摹，或查看 - >立即窗口