VBA需求：跨工作簿匹配特定标识并实现数值递增拼接

Got it, let's tackle this problem step by step. You need to extend your existing VBA macro to pull incremented identifiers from another workbook, right? Here's how to modify your code to meet all requirements:

Prerequisite: Enable Microsoft Scripting Runtime #

First, make sure you've enabled the Microsoft Scripting Runtime reference in your VBA editor:

• Open the VBA Editor (Alt + F11)
• Go to Tools > References
• Check the box next to Microsoft Scripting Runtime and click OK

Modified Full VBA Code #

Here's the updated TralaNome subroutine with all the required cross-workbook lookup and increment logic included:

Sub TralaNome()
    Const q = """"
    Dim targetWB As Workbook
    Dim targetWS As Worksheet
    Dim targetCol As Long
    Dim lastRow As Long
    Dim regex As Object
    Dim maxNumbers As Dictionary
    Dim currentCell As Range
    Dim matchResult As Object
    Dim baseID As String
    Dim currentNum As Long
    Dim newID As String
    
    ' Initialize regex to extract identifier and number
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "(Noupa|Noupu|Noupx|Noupy)(\d+)"
    regex.Global = False
    
    ' Initialize dictionary to track max numbers for each identifier type
    Set maxNumbers = New Dictionary
    maxNumbers("Noupa") = 0
    maxNumbers("Noupu") = 0
    maxNumbers("Noupx") = 0
    maxNumbers("Noupy") = 0
    
    ' Get target workbook (you can hardcode the path or use a file picker)
    Dim filePath As Variant
    filePath = Application.GetOpenFilename("Excel Files (*.xlsx;*.xls), *.xlsx;*.xls", Title:="Select the Workbook with Identifiers")
    If filePath = False Then Exit Sub ' User canceled file picker
    Set targetWB = Workbooks.Open(filePath)
    
    ' Find the column with fixed header name (replace with your actual header)
    Const TARGET_HEADER As String = "YourFixedColumnName" ' Update this to your real column name
    Set targetWS = targetWB.Sheets(1) ' Adjust sheet name if needed
    On Error Resume Next
    targetCol = targetWS.Rows(1).Find(TARGET_HEADER, LookIn:=xlValues, LookAt:=xlWhole).Column
    On Error GoTo 0
    If targetCol = 0 Then
        MsgBox "Target column '" & TARGET_HEADER & "' not found in the selected workbook."
        targetWB.Close SaveChanges:=False
        Exit Sub
    End If
    
    ' Get last row with data in target column
    lastRow = targetWS.Cells(targetWS.Rows.Count, targetCol).End(xlUp).Row
    
    ' Loop through target column to find max numbers for each identifier type
    For Each currentCell In targetWS.Range(targetWS.Cells(2, targetCol), targetWS.Cells(lastRow, targetCol))
        If currentCell.Value <> "" Then
            Set matchResult = regex.Execute(currentCell.Value)
            If matchResult.Count > 0 Then
                baseID = matchResult(0).SubMatches(0)
                currentNum = CLng(matchResult(0).SubMatches(1))
                If currentNum > maxNumbers(baseID) Then
                    maxNumbers(baseID) = currentNum
                End If
            End If
        End If
    Next currentCell
    
    ' --- Existing Logic Starts Here ---
    ' Get source data table from sheet 1
    With ThisWorkbook.Sheets(1).Cells(1, 1).CurrentRegion
        ' Check if data exists
        If .Rows.Count < 2 Or .Columns.Count < 2 Then
            MsgBox "No data table"
            targetWB.Close SaveChanges:=False
            Exit Sub
        End If
        ' Retrieve headers name and column numbers dictionary
        Dim headers As Dictionary
        Set headers = New Dictionary
        Dim headCell
        For Each headCell In .Rows(1).Cells
            headers(headCell.Value) = headers.Count + 1
        Next
        ' Check mandatory headers
        For Each headCell In Array("Costumer", "ID", "Zone", "Product Quali", "Spec A", "Spec B", "Spec_C", "Spec_D", "Spec_1", " Spec_2", " Spec_3", " Spec_4", " Spec_5", " Spec_6", " Spec_7", "Chiavetta", "Tipo_di _prodotto", "Unicorno_Cioccolato", "cacao tree")
            If Not headers.Exists(headCell) Then
                MsgBox "Header '" & headCell & "' doesn't exist"
                targetWB.Close SaveChanges:=False
                Exit Sub
            End If
        Next
        Dim data
        ' Retrieve table data
        data = .Resize(.Rows.Count - 1).Offset(1).Value
    End With
    
    ' Process each row in table data
    Dim result As Dictionary
    Set result = New Dictionary
    Dim i As Long
    Dim baseIdentifier As String ' Adjust this to get the correct type from your source data
    ' Note: Replace this hardcode with logic to fetch the identifier type per row (e.g., from a source column)
    baseIdentifier = "Noupa" ' Update this based on your actual data structure
    
    For i = 1 To UBound(data, 1)
        ' Skip empty rows
        If Trim(data(i, headers("ID"))) <> "" Then
            ' Increment the max number for the identifier type
            maxNumbers(baseIdentifier) = maxNumbers(baseIdentifier) + 1
            ' Format the new ID with leading zeros (adjust digit count as needed)
            newID = baseIdentifier & Format(maxNumbers(baseIdentifier), "000")
            
            ' Combine with original concatenated content
            result(result.Count) = _
                q & "ID " & data(i, headers("ID")) & _
                q & " Tipo_di _prodotto " & data(i, headers("Tipo_di _prodotto")) & _
                q & " cacao tree " & data(i, headers("cacao tree")) & _
                q & " Incremented ID: " & newID & q
        End If
    Next
    
    ' Output result data to sheet 2
    If result.Count = 0 Then
        MsgBox "No result data for output"
        targetWB.Close SaveChanges:=False
        Exit Sub
    End If
    With ThisWorkbook.Sheets(2)
        .Cells.Delete
        .Cells(1, 1).Resize(result.Count).Value = _
            WorksheetFunction.Transpose(result.Items())
    End With
    
    ' Optional: Save the updated max numbers back to the target workbook
    targetWB.Close SaveChanges:=True ' Change to False if you don't want to save updates
    
    MsgBox "Completed"
End Sub

' Corrected version of your reference function
Function GetLastRowWithData(WorksSheetNoupa As Worksheet, Optional NoupaLastCol As Long) As Long
    Dim lCol, lRow, lMaxRow As Long
    If NoupaLastCol = 0 Then
        NoupaLastCol = WorksSheetNoupa.Columns.Count
    End If
    lMaxRow = 0
    For lCol = NoupaLastCol To 1 Step -1
        lRow = WorksSheetNoupa.Cells(WorksSheetNoupa.Rows.Count, lCol).End(xlUp).Row
        If lRow > lMaxRow Then
            lMaxRow = lRow
        End If
    Next
    GetLastRowWithData = lMaxRow
End Function

Key Changes Explained #

Let's break down the new logic added:

1. Regex for Reliable Matching: We use a regular expression to extract the base identifier (Noupa/Noupu/etc.) and its trailing number. This handles variable-length numbers and ensures we only target your specified identifier types.
2. Cross-Workbook Lookup: The macro uses a file picker to let you select the target workbook, then locates the column with your fixed header name (don't forget to update TARGET_HEADER to your actual column name).
3. Track Maximum Numbers: A dictionary keeps tabs on the highest number found for each identifier type, so we can increment from the latest value.
4. Increment & Format: For each row in your source data, we increment the max number and format it with leading zeros (adjust the "000" in Format() if you need more/less digits).
5. Integrate with Original Content: The new incremented ID is appended to your existing concatenated string.
6. Cleanup: The target workbook is closed with an option to save changes (so your next run uses the updated max numbers).

Important Notes: #

• Update TARGET_HEADER to match the exact column name in your target workbook.
• Adjust the baseIdentifier logic: Right now it's hardcoded to "Noupa"—replace this with logic to fetch the correct identifier type per row (e.g., pull from a column in your source sheet).
• Modify the Format() string if you need a different number of leading zeros (e.g., "00" for two digits, "0000" for four).

内容的提问来源于stack exchange，提问作者Elvino Michel