Question

我正在尝试为以下日常任务找到自动解决方案。我有一张13页的主工作簿。

名称是Jan-Dec（全部12个月）和数据。

每张纸有2组3列：商品代码（A1），年份（B1），价格（C1）和商品代码（E1），年份（F1），价格（G1）。

每天我在＆＃34;数据＆＃34;中有超过1000个新条目。工作表然后必须在其他12张工作表A-C中找到匹配的商品代码（在A列中），剪切并将新的匹配数据移动到E-G并突出显示新条目。

我尝试了以下vba代码：

Sub TestNewCode()
Application.ScreenUpdating = False
Dim varMainRange As Range
Dim varSubRange As Range
Set varMainRange = Range(Worksheets("Jul").Range("A2:C65536"), _
Worksheets("Jul").Range("A65536").End(xlUp))
For Each MainCell In varMainRange
    Set varSubRange = Range(Worksheets("Data").Range("A2"), _
    Worksheets("Data").Range("A65536").End(xlUp))
    For Each SubCell In varSubRange
        If MainCell.Value = SubCell.Value Then
    Worksheets("Data").Range("A2:C2").Copy _
    Worksheets("Jul").Range("E2:G2")
            Exit For
        End If
    Next SubCell
Next MainCell
Application.ScreenUpdating = True 
End Sub

正如您所看到的，此代码只能移动一个单元格。如果有人能够解决这个问题，我会很感激。

Answer 1

我没有对此代码进行全面测试，部分原因是我怀疑您确实希望将数据发布到12个月的任何一张表中。相反，我怀疑数据必须发布到月度表中的一个特定页面。但是，这并不是你所说的，因此我的代码会查看所有工作表并停止查找它找到匹配项。您可能会发现这很容易调整。否则我可以帮你做。

但是，此代码现在需要的是彻底的测试。： - ）

Sub TestNewCode()
    ' 16 Sep 2017

    Const Tabs As String = "Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"

    Dim WsData As Worksheet
    Dim Ws As Worksheet                             ' any of the monthly sheets
    Dim WsName() As String
    Dim Rend As Long, Rl As Long                    ' last row in WsData / Ws
    Dim R As Long, Rm As Long                       ' row counter WsData / Ws
    Dim Entry As Variant                            ' one Data entry

    Set WsData = Worksheets("Data")
    WsName = Split(Tabs, " ")
    Application.ScreenUpdating = False
    With WsData
        Rend = .Cells(.Rows.Count, "A").End(xlUp).Row
        For R = 2 To Rend
            Entry = .Range(.Cells(R, 1), .Cells(R, 3)).Value     ' A:C
            Rm = FindMatch(Entry, Ws, WsName)
            If Rm Then                              ' rm = 0 if not found
                With Ws.Cells(Rm, 5).Resize(1, UBound(Entry, 2))
                    .Value = Entry
                    .Interior.Color = vbYellow
                End With
            End If
        Next R
    End With
    Application.ScreenUpdating = True
End Sub

Private Function FindMatch(Entry As Variant, _
                           Ws As Worksheet, _
                           WsName() As String) As Long
    ' return zero if no match was found

    Dim Rng As Range                        ' search range
    Dim Fnd As Range
    Dim Rl As Long
    Dim i As Long

    For i = 0 To UBound(WsName)
        On Error Resume Next
        Set Ws = Worksheets(WsName(i))
        If Err Then
            MsgBox "Worksheet " & WsName(i) & " doesn 't exist.", _
                   vbInformation, "Missing worksheet"
        Else
            With Ws
                Rl = .Cells(.Rows.Count, 1).End(xlUp).Row
                Set Rng = .Range(.Cells(2, 1), .Cells(Rl, 3))
                Set Fnd = Rng.Find(What:=Entry(1, 1), _
                      After:=Rng.Cells(Rng.Cells.Count), _
                      LookIn:=xlValues, _
                      Lookat:=xlWhole, _
                      SearchOrder:=xlByColumns, _
                      SearchDirection:=xlNext, _
                      MatchCase:=False, _
                      MatchByte:=False)
                If Not Fnd Is Nothing Then
                    FindMatch = Fnd.Row
                    Exit For
                End If
            End With
        End If
    Next i
    If Fnd Is Nothing Then
        MsgBox "Code " & Entry(1, 1) & " wasn't found.", _
               vbInformation, "Missing Code"
    End If
End Function

用于查找，匹配和移动数据的VBA

1 个答案: