Question

我在Excel工作表中有一个矩阵。在第一列是计算机的名称，在其他行中，我有用户正在使用它。对于每台计算机，可以有一个关联用户或两个用户，依此类推。

我希望在列中创建一个计算机矩阵，并在行中创建所有用户，并使用VBA代码搜索工作表，如果用户使用该计算机，则输出应为yes，否则no。

主要表

Computer A   Dev     Priya   Rakesh  Joseph     
Computer B   Rakesh  Joseph             
Computer C   John    Nisha   Dev

输出表

Computers     Dev   Priya   Rakesh  Joseph  John    Nisha

Computer A     Y     Y       Y        Y      N       N  
Computer B     N     N       Y        Y      N       N  
Computer C     Y     N       N        N      Y       Y

Answer 1

将表格重命名为＆＃39; Main＆＃39;并将数据复制到它从范围A1开始请注意空白单元格，因为我通过检查单元格检查行和列的结尾是＆＃34;＆＃34; 将其他工作表重命名为＆＃39;输出＆＃39;。
复制我的代码然后运行。
注意：输出表将一直清除您运行此宏。

Sub createMatrix()
Dim i As Long
Dim j As Long
Dim k As Long
Dim rngFind As Range

' Clear all contents in sheets output
Sheets("Output").Activate
Sheets("Output").Cells.ClearContents

i = 0
j = 1
k = 1
Do While Sheets("Main").Range("A1").Offset(i).Value <> ""
    ' Insert computer name to output sheet
    Sheets("Output").Range("A2").Offset(i).Value = Sheets("Main").Range("A1").Offset(i).Value

    Do While Sheets("Main").Range("A1").Offset(i, j).Value <> ""
        ' Check name is exists?
        Set rngFind = Rows("1:1").Find(what:=Sheets("Main").Range("A1").Offset(i, j).Value, LookAt:=xlWhole)
        If rngFind Is Nothing Then
            ' If not exists paste new name
            Sheets("Output").Range("A1").Offset(0, k).Value = Sheets("Main").Range("A1").Offset(i, j).Value

            ' Mark use as 'Y'
            Sheets("Output").Range("A1").Offset(i + 1, k).Value = "Y"
            k = k + 1
        Else
            ' Mark use as 'Y'
            rngFind.Offset(i + 1).Value = "Y"
        End If

        j = j + 1
    Loop
    i = i + 1
    j = 1
Loop

' This loop for Mark 'N'
i = 0
j = 1
Do While Sheets("Output").Range("A2").Offset(i).Value <> ""
    Do While Sheets("Output").Range("A1").Offset(0, j).Value <> ""
        ' If found blank cell Mark 'N'
        If Sheets("Output").Range("A2").Offset(i, j).Value = "" Then
            Sheets("Output").Range("A2").Offset(i, j).Value = "N"
        End If
        j = j + 1
    Loop
    i = i + 1
    j = 1
Loop
End Sub

示例主表和输出

Answer 2

此版本创建新工作表

Option Explicit

Public Sub TheMatrixReloaded()  'There is no spoon
   Const FR As Long = 1:   Const FC As Long = 2
   Dim ws1 As Worksheet, ws2 As Worksheet, lr As Long, ur As Range
   Dim ud As Object, cel As Range, i As Long
   Set ws1 = ThisWorkbook.Worksheets("Sheet1")
   With ws1.UsedRange
     lr = ws1.Cells(.Rows.Count + .Row + 1, FC - 1).End(xlUp).Row
     Set ur = ws1.Range(ws1.Cells(FR + 1, FC), ws1.Cells(lr, .Columns.Count + .Column - 1))
   End With
   Set ud = CreateObject("Scripting.Dictionary")
   Application.ScreenUpdating = False
   Set ws2 = ThisWorkbook.Worksheets.Add(After:=ws1)
   ws1.Range(ws1.Cells(FR, FC - 1), ws1.Cells(lr, FC - 1)).Copy ws2.Cells(FR, FC - 1)
   For Each cel In ur
      With cel
         If Len(.Value2) > 0 Then
            If Not ud.Exists(.Value2) Then
               ud.Add .Value2, FC + i
               ws2.Cells(FR, FC + i).Value2 = .Value2
               ws2.Cells(.Row, FC + i).Value2 = "Y":  i = i + 1
            Else
               ws2.Cells(.Row, ud(.Value2)).Value2 = "Y"
            End If
         End If
      End With
   Next
   With ws2.UsedRange
      Set ur = ws2.Range(ws2.Cells(FR + 1, FC), ws2.Cells(.Rows.Count, .Columns.Count))
      Set ur = ur.SpecialCells(xlCellTypeBlanks)
   End With
   ur.Value2 = "N": ur.Font.Color = RGB(177, 177, 177)
   ws2.Columns(1).AutoFit: ws2.UsedRange.HorizontalAlignment = xlCenter
   ws2.Rows(2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
   Application.ScreenUpdating = True
End Sub

使用＆＃39; yes＆＃39;填充矩阵的代码或者没有＆＃39;基于输入

2 个答案: