Question

我在一个工作簿中有18000个带有CPV产品代码的项目，并且这些CPV代码中的每一个都对应于可以在特定文件夹中的45个工作簿之一中找到的UNSPC代码。对于每个CPV代码，我想搜索这些其他工作簿，直到找到它们，然后将相应的UNSPC代码复制到原始工作簿中CPV代码旁边的列中的单元格。

目前，我的代码是：

Sub findUNSPC()
Dim file As String
Dim app As New Excel.Application
Dim book As Excel.Workbook
Dim StartNumber As Integer, EndNumber As Integer, check As Integer, cpv As Long, unspc As Long
EndNumber = Sheet2.Range("D" & Rows.Count).End(xlUp).Row

For StartNumber = 2 To EndNumber
Sheet2.Cells(StartNumber, 4).Activate
    cpv = ActiveCell.Value
file = Dir("C:\Users\Gylfi.heimisson\Documents\Enzen\CPV to UNSPSC\" & "*.xlsx")
    Do While Len(file) > 0
    Debug.Print file
        file = Dir
        Set book = app.Workbooks.Add("Source Directory" & file) 'Source Directory is just where the files are located on my computer
        book.Worksheets("Mappings").Activate
        check = book.Application.WorksheetFunction.Match(cpv, "B:B", 0)
            If check <> "#N/A" Then
            unspc = book.Application.WorksheetFunction.Index("S:S", check)
            End If
    Loop
book.Close SaveChanges:=False
app.Quit
Set app = Nothing
ActiveCell.Offset(0, 1).Value = usnpc
Next StartNumber
End Sub

我在第17行收到运行时错误'1004'：应用程序定义或对象定义的错误。我也不确定代码的其余部分。

我意识到我可能也以低效的方式写了这个，所以对我做错了什么以及如何让它工作的任何建议都将不胜感激！

Answer 1

试试这个：

Sub FindUNSPC()

    Dim FileName As String
    Dim TargetBk As Workbook, TargetSht As Worksheet
    Dim StartNumber As Long, EndNumber As Long
    Dim CurrCell As Range, FoundCell As Range
    Dim CPV As Variant, UNSPC As Variant

    EndNumber = ThisWorkbook.Sheet2.Range("D" & Rows.Count).End(xlUp).Row

    For StartNumber = 2 to EndNumber

        Set CurrCell = Sheet2.Range("D" & StartNumber)
        CPV = CurrCell.Value
        FileName = Dir("C:\Users\Gylfi.heimisson\Documents\Enzen\CPV to UNSPSC\" & "*.xlsx")

        Do While Len(FileName) > 0

            Debug.Print FileName
            Set TargetBk = Workbooks.Add("SrcDir" & FileName) 'Modify as necessary.
            Set TargetSht = TargetBk.Sheets("Mappings")

            With TargetSht.Range("B:B")
                On Error Resume Next
                Set FoundCell = .Find What:=CPV
                If Not FoundCell Is Nothing Then
                    USNPC = FoundCell.Offset(0,17).Value
                End If
                On Error GoTo 0
            End With

            TargetBk.Close

        Loop

        CurrCell.Offset(0, 1).Value = USNPC

    Next StartNumber

End Sub

首先，请停止使用.Activate。这不是好代码。请参阅here，了解为什么以及可以用作替代品的一些原因。

其次，在VBA中使用.Find比使用Match-Index返回值要好得多，因为后者会导致各种麻烦。如果我理解您的意图，您只需要在B列中检查CPV是否存在，并从相应的S列返回值。

上面代码中的

.Find也在B列中查找CPV，如果S返回有效范围，则返回.Find中偏离17列的值（.FoundCell）。我们将找到的值分配给USNPC并关闭中的内容循环，然后我们打开它。在循环之外，我们将USNPC输入到CPV的右侧单元格。然后我们再次循环下一个CPV。

以上内容几乎与您所拥有的内容相同，因此可能会有一个部分引发错误。如果这有效（或没有），请告诉我们。

Answer 2

根据BK201的代码，我编写了一个似乎有用的版本。

Sub FindUNSPC()

Dim FileName As String
Dim TargetBk As Excel.Workbook, TargetSht As Excel.Worksheet
Dim StartNumber As Long, EndNumber As Long
Dim CurrCell As Range, FoundCell As Range
Dim CPV As Variant, UNSPC As Variant

EndNumber = Sheet2.Range("D" & Rows.Count).End(xlUp).Row


FileName = Dir("C:\Users\Gylfi.heimisson\Documents\Enzen\CPV to UNSPSC\" & "*.xlsx")

    Do While Len(FileName) > 0

     Debug.Print FileName
        FileName = Dir
        Set TargetBk = Workbooks.Add("C:\Users\Gylfi.heimisson\Documents\Enzen\CPV to UNSPSC\" & FileName)
        Set TargetSht = TargetBk.Sheets("Mappings")

        For StartNumber = 2 To EndNumber
            Set CurrCell = Sheet2.Range("D" & StartNumber)
            If CurrCell.Offset(0, 1).Value <> "" Then
            GoTo Here
            End If
            CPV = CurrCell.Value

        With TargetSht.Range("B:B")
            On Error Resume Next
            Set FoundCell = .Find(What:=CPV)
            If Not FoundCell Is Nothing Then
                UNSPC = FoundCell.Offset(0, 17).Value
                CurrCell.Offset(0, 1).Value = UNSPC
            End If
            On Error GoTo 0
        End With

Here:       Next StartNumber

        If FileName = "C:\Users\Gylfi.heimisson\Documents\Enzen\CPV to UNSPC\Mapping 98_Other_Community_Social_Personal_Services.xlsx" Then
        TargetBk.Close SaveChanges:=False
        Exit Do
        Else
        TargetBk.Close SaveChanges:=False
        End If


    Loop


End Sub

根据产品代码从不同工作簿中提取数据

2 个答案: