Die erste Spalte meiner Tabelle ist eine Liste mit Teamnamen. Die nächsten Spalten enthalten Spielernamen. Ein Spieler kann in mehr als einem Team sein. Schließlich habe ich eine Spalte mit einer Liste mit Spielernamen.
Ich möchte die Liste der Spieler durchgehen und herausfinden, in welchen Teams jeder Spieler ist. Die Reihenfolge ist nicht wichtig
Wie kann ich das machen?
Beispielsweise gegeben:
red | tom | bob | sally | emma
blue | tom | george | bill | sally
green | george | bob
yellow | sally| arthur | george | emma
Ich hätte gerne folgendes Ergebnis:
tom | red | blue
bob | red | green
sally | red | blue | yellow
george | blue | green | yellow
arthur | yellow
emma | yellow | red
Antwort1
Dazu müssen Sie VBA aktivieren. Anschließend fügen Sie Folgendes in Ihren VBA-Editor ein:
Sub CreateWorksheet_TransposedListing(inputData As Range, worksheetName As String)
AddNumberedSheet worksheetName
Dim new_sheet As Worksheet
Set new_sheet = Sheets(Sheets.Count)
Dim nRowDx As Integer, nColDx As Integer
Dim sValue As String, sHeader As String, sAddress As String
For nRowDx = 1 To inputData.Rows.Count
For nColDx = 1 To inputData.Columns.Count
If nColDx = 1 Then
sValue = Trim(inputData.Cells(nRowDx, nColDx).Value)
Else
sHeader = Trim(inputData.Cells(nRowDx, nColDx).Value)
sAddress = FindNextHeaderCell(new_sheet.Name, sHeader)
If sAddress = "" Then Exit Sub
new_sheet.Range(sAddress) = sValue
End If
Next
Next
End Sub
Function FindNextHeaderCell(sSheet As String, sRowHeaderName As String) As String
Dim nRowDx As Integer, nColDx As Integer
For nRowDx = 1 To 32766
If IsEmpty(Worksheets(sSheet).Cells(nRowDx, "A")) Then
Worksheets(sSheet).Cells(nRowDx, "A") = sRowHeaderName
FindNextHeaderCell = Worksheets(sSheet).Cells(nRowDx, "B").Address
Exit Function
ElseIf Worksheets(sSheet).Cells(nRowDx, "A") = sRowHeaderName Then
For nColDx = 2 To 32766
If IsEmpty(Worksheets(sSheet).Cells(nRowDx, nColDx)) Then
FindNextHeaderCell = Worksheets(sSheet).Cells(nRowDx, nColDx).Address
Exit Function
End If
Next
If nColDx > 32766 Then
MsgBox "This result is larger than VBA will support. Results have been truncated."
FindNextHeaderCell = ""
Exit Function
End If
End If
Next
If nRowDx > 32766 Then
MsgBox "This result is larger than VBA will support. Results have been truncated."
End If
FindNextHeaderCell = ""
End Function
Sub AddNumberedSheet(Optional sWorksheetName As String, Optional bSelectWorksheet As Boolean)
Dim sheet_name As String, num_text As String
Dim i As Integer, new_num As Integer, max_num As Integer
Dim new_sheet As Worksheet
max_num = 0
For i = 1 To Sheets.Count
sheet_name = Sheets(i).Name
If Left$(sheet_name, Len(sWorksheetName)) = sWorksheetName Then
num_text = Mid$(sheet_name, Len(sWorksheetName) + 1)
new_num = Val(num_text)
If new_num > max_num Then max_num = new_num
End If
Next i
Set new_sheet = Sheets.Add(after:=Sheets(Sheets.Count))
new_sheet.Name = sWorksheetName & Format$(max_num + 1)
If bSelectWorksheet Then new_sheet.Select
End Sub
Dann möchten Sie eine Methode hinzufügen, die diese aufruft. Wenn Sie beispielsweise eine Schaltfläche haben, verwenden Sie etwas wie das Folgende:
Sub Button1_Click()
CreateWorksheet_TransposedListing Range("A1:E4"), "TestSheet"
End Sub