搜索字符串和与该字符串对应的输出值-解网

问：

日安

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

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

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

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

搜索完资源 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 VBA 函数循环 if-statement

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

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

0赞 VBasic2008 8/18/2023 #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

上一个：如果键列中的值匹配，则将列数据从一个工作表复制到另一个工作表

下一个：通过带有条件的VBA将Excel单元格数据从一列移动到另一列

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

Search for a string and output values corresponding to that string

评论

转换数据