主页 / coding / 问题 / 76926888
Accepted
Thembelihle Sindiswa Sithole
Asked: 2023-08-18 14:25:15 +0800 CST

搜索字符串并输出与该字符串对应的值

  • 772

再会

我的目标是创建一个水平增长的列表（按列）。表1有五列和若干行进行增加，（列A-主任务），（列B-子任务），（列C-资源1执行任务），（列D-资源2执行相同的任务），（E-资源 3 列执行相同的任务）。注意：每个主任务可以有多个子任务，如果是这样，多个单元格（主任务）将被合并以对应于主任务对应的多个子任务。

表2列出了A列中列出的所有资源。这些资源可能已经/未出现在表2（C/D/E列）中，即分配了子任务/主任务。

我的代码旨在搜索表 1 中的每个资源，搜索分配给它的任务和子任务并输出这些结果，如图所示。

代码创建时的计划是：代码必须使用A列中的资源名称-表2作为索引，用它来搜索表1中第一列的资源，如果找到匹配，则输出A列中的值桌子。并继续搜索相同的资源，如果找到则输出。接下来在下一列中搜索相同的资源，然后是下一列。

搜索完资源 aa 后，它会在 c 列中搜索资源 bb，然后是 d，然后是最后一个。实时输入结果值。

非常感谢您对修改我所拥有的内容的帮助。

在下面的代码中，表格位于不同的工作表中。这很好，也可以实施。

Sub SearchResourceNames()
    
    'Declare variables
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim r As Range, c As Range, i As Long, j As Long, k As Long
    Dim resource As String, task As String, col As Long
    
    'Set the worksheets
    Set ws1 = ThisWorkbook.Sheets("Table1")
    Set ws2 = ThisWorkbook.Sheets("Table2")
    
    'Initialize variables
    i = 2
    j = 2
    k = 2
    col = 2
    
    'Loop through the resources in table 2
    For Each r In ws2.Range("A1:A10")
    
    'Get the resource name
    resource = r.Value
    
    'Initialize flag to indicate if task has been found
    found = False
    
    'Loop through the tasks in table 1
    For Each c In ws1.Range("A:A")
    
    'If the resource is found in the current task,
    If c.Value = resource Then
    
    'Set the flag to indicate that the task has been found
    found = True
    
    'Get the task name
    task = c.Offset(0, col).Value
    
    'If the task has not been found before,
    If Not ws2.Range("B" & k).Value = task Then
    
    'Add the task name to the output column
    ws2.Range("B" & k).Value = task
    
    'Increment the output column index
    k = k + 1
    
    End If
    
    End If
    
    Next c
    
    'If the task was not found in any of the tasks,
    If Not found Then
    
    'Print a message to the user
    MsgBox "The resource " & resource & " was not found in any of the tasks."
    
    End If
    
    Next r
    
    'Move to the next column in table 2
    col = col + 1
    
    'Reset the output column index
    k = 2
    
End Sub

数据和期望的输出：

在此输入图像描述

当前不需要的输出

在此输入图像描述

excel

2 个回答

  1. Best Answer

    我建议创建一个所有资源的字典。该资源字典中的每个条目都会再次获得该资源需要处理的所有任务的字典。

    只有构建完整的词典后，才会将其转储到结果表中。

    如果您不熟悉词典：有很多文档，例如此处。请注意，我使用的是早期绑定，因此您必须添加对 Microsoft 脚本运行时的引用。

    构建资源字典的代码相当简单。出于速度原因，我首先将 的完整数据读Table1入一个二维数组（我称之为data）。然后，代码循环遍历所有资源列的所有行并读取资源名称。如果它不在字典中（它是“新的”），我们taskDict为该条目创建一个新的字典（）。然后将任务添加到任务字典中，并将资源添加到资源字典中。

    Function fillResourceDict() As Dictionary
    
    ' (1) Read data from table1
    Dim data As Variant
    Dim lastRow As Long, row As Long
    Dim lastCol As Long, col As Long
    
    With ThisWorkbook.Sheets("Table1")
        lastRow = .Cells(.Rows.Count, 2).End(xlUp).row
        lastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
        
        data = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
        ' Fill in empty values in column 1 (because of the unholy merged cells)
        For row = 3 To lastRow
            If IsEmpty(data(row, 1)) Then data(row, 1) = data(row - 1, 1)
        Next row
    End With

    ' (2) Build the resouce-Dictionary. Loop over all recource columns
    Dim resourceDict As New Dictionary
    For row = 3 To lastRow
        For col = 3 To lastCol
            Dim resource As String, task As String, taskDict As Dictionary
            resource = data(row, col)
            If resource <> "" Then
                If resourceDict.Exists(resource) Then
                    ' Read the taskDict from existing resource
                    Set taskDict = resourceDict(resource)
                Else
                    ' New resource: Create a new Dictionary
                    Set taskDict = New Dictionary
                End If
                task = data(row, 1) & "-" & data(row, 2)
                taskDict(task) = task    ' add Task
                Set resourceDict(resource) = taskDict
            End If
        Next col
    Next row
            
    Set fillResourceDict = resourceDict
End Function

    现在剩下要做的就是调用这个函数并将结果填充到 table2 中：

    Sub fillToDoList()
    
    Dim resourceDict As Dictionary
    Set resourceDict = fillResourceDict
    
    With ThisWorkbook.Sheets("Table2")
        .UsedRange.ClearContents
        Dim resource As Variant, row As Long
        .Cells(1, 1) = "Resource"
        .Cells(1, 2) = "ToDo list"
        row = 2
        
        For Each resource In resourceDict.Keys
            .Cells(row, 1) = resource
            Dim taskDict As Dictionary
            Set taskDict = resourceDict(resource)
            .Cells(row, 2).Resize(1, taskDict.Count).Value = taskDict.Keys
            row = row + 1
        Next
    End With
End Sub
    • 1

  2. 转换数据

    在此输入图像描述 在此输入图像描述

    Option Explicit

Sub GenerateResources()
    
    ' Constants
    
    Const SRC_SHEET As String = "Table1"
    Const SRC_MAIN_COLUMN As Long = 1
    Const SRC_SUB_COLUMN As Long = 2
    Const SRC_FIRST_DATA_CELL As String = "A2"
    Const DST_SHEET As String = "Table2"
    Const DST_FIRST_TABLE_CELL As String = "A1"
    Const DST_HEADERS As String = "Resource,To-Do List"
    Const DST_MAIN_SUB_DELiMiTER As String = "-"

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET)
    Dim sfCell As Range: Set sfCell = sws.Range(SRC_FIRST_DATA_CELL)
    
    Dim srg As Range:
    
    With sfCell.CurrentRegion
        Set srg = sfCell.Resize(.Row + .Rows.Count - sfCell.Row, _
            .Column + .Columns.Count - sfCell.Column)
    End With

    Dim scCount As Long: scCount = srg.Columns.Count
    
    If scCount < 3 Then
        MsgBox "Not enough columns.", vbCritical
        Exit Sub
    End If
    
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim sData(): sData = srg.Value
    
    ' Unique resources to the keys, and the resources' rows to the keys
    ' of another (inner) dictionary held by each item of the outer dictionary.
    
    Dim rDict As Object: Set rDict = CreateObject("Scripting.Dictionary")
    rDict.CompareMode = vbTextCompare
    
    Dim sr As Long, sc As Long, rStr As String, rMaxCount As Long
    
    For sr = 1 To srCount
        For sc = 1 To scCount
            If sc <> SRC_MAIN_COLUMN And sc <> SRC_SUB_COLUMN Then
                rStr = CStr(sData(sr, sc))
                If Len(rStr) > 0 Then
                    If Not rDict.Exists(rStr) Then
                        Set rDict(rStr) = CreateObject("Scripting.Dictionary")
                    End If
                    If Not rDict(rStr).Exists(sr) Then
                        rDict(rStr)(sr) = Empty
                        If rDict(rStr).Count > rMaxCount Then
                            rMaxCount = rDict(rStr).Count
                        End If
                    End If
                End If
            End If
        Next sc
    Next sr
    
    Dim dcCount As Long: dcCount = rDict.Count + 1
    
    If dcCount = 1 Then
        MsgBox "No resources found.", vbCritical
        Exit Sub
    End If
    
    ' Join mains and subs. Each row to the keys and each 'join' to the items
    ' of a dictionary
    
    Dim msDict As Object: Set msDict = CreateObject("Scripting.Dictionary")
    
    Dim mStr As String, cmStr As String, sStr As String, tStr As String
    Dim IsMainFound As Boolean
    
    For sr = 1 To srCount
        mStr = CStr(sData(sr, SRC_MAIN_COLUMN))
        If IsMainFound Then
            If Len(mStr) = 0 Then
                mStr = cmStr
            Else
                cmStr = mStr
            End If
            sStr = CStr(sData(sr, SRC_SUB_COLUMN))
            If Len(sStr) > 0 Then
                tStr = mStr & DST_MAIN_SUB_DELiMiTER & sStr
                msDict(sr) = tStr
            End If
        Else
            If Len(mStr) > 0 Then
                IsMainFound = True
                sr = sr - 1
            End If
        End If
    Next sr
    
    ' Using the information from the dictionaries,
    ' generate the destination (result) array.
    
    Dim dData(): ReDim dData(1 To msDict.Count + 1, 1 To dcCount)
    
    Dim dHeaders() As String: dHeaders = Split(DST_HEADERS, ",")
    dData(1, 1) = dHeaders(0)
    dData(1, 2) = dHeaders(1)
    
    Dim dr As Long: dr = 1
    
    Dim orKey, irKey, dc As Long
    
    For Each orKey In rDict.Keys
        dr = dr + 1
        dData(dr, 1) = orKey
        dc = 1
        For Each irKey In rDict(orKey).Keys
            If msDict.Exists(irKey) Then
               dc = dc + 1
               dData(dr, dc) = msDict(irKey)
            End If
        Next irKey
    Next orKey

    ' Destination

    Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET)
    Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_TABLE_CELL)
    Dim drg As Range: Set drg = dfCell.Resize(dr, dcCount)
    
    With drg
        
        ' Clear and write.
        .EntireColumn.Clear
        .Value = dData
        
        ' Format.
        
        ' Merge and center second header.
        With .Resize(1, dcCount - 1).Offset(, 1)
            .Merge
            .HorizontalAlignment = xlCenter
        End With
        ' All borders
        .Borders.Weight = xlThin
        ' All headers
        With .Resize(1)
            .Font.Bold = True
        End With
        ' All entire columns
        With .EntireColumn
            .AutoFit
            ' Resource columns only
            With .Resize(, dcCount - 1).Offset(, 1)
                .ColumnWidth = 4
            End With
        End With
        ' Resource data only (no headers)
        With .Resize(dr - 1, dcCount - 1).Offset(1, 1)
            .HorizontalAlignment = xlCenter
        End With
        
        ' etc.
    
    End With
    
    MsgBox "Resources generated.", vbInformation
    
End Sub
    • 0

相关问题