Hallo Michael,
ich wollte nur ein wenig Drama.
Die Infos die man braucht, sind immer die gleichen, wo genau stehen die Daten?
Nach Deinen letzten Angaben hast Du zwei getrennte Bereiche.
B-DH mit JA/NEIN
IB-ID mit Projekt und Namen
Die JA/NEIN und Projekt etc beginnen ab Zeile 7 gehen bis Zeile 4500
Das sind die Vorgaben, unter denen ich den unten eingestellten Code erarbeitet habe.
Code:
Sub tabellenAnlegen1()
Dim i As Long, j As Long, k As Long
Dim strgText As String
Dim aktWks As Worksheet
Dim wks As Worksheet
Dim tmpWks As Worksheet
Dim arr As Variant, arr2 As Variant
Dim D1 As Object
Dim varK
Set D1 = CreateObject("Scripting.Dictionary")
On Error GoTo fehler
Application.ScreenUpdating = False
tab_löschen 'alle Tabllen werden bis auf die in der Prozedur "tab_löschen" angegebenen gelöscht
strgText = "NEIN"
Set aktWks = Worksheets("Teilnehmende-Stammdatenblatt")
aktWks.Copy before:=aktWks 'Kopie der Datentabelle wird angelegt
Set tmpWks = ActiveSheet
With tmpWks 'Kopie der Datentabelle
.Range("B7:DH4500").Name = "ati" 'Bereich mit JA/NEIN
[ati] = [if(iserr(search("Nein",ati)),"",column(ati))] 'alle Ja aus dem Bereich werden entfernt und für Nein wird Spaltenzahl eingetragen
arr = .Range("ati")
arr2 = .Range("IB7:ID4500") '- Spalten A-C in Quelle, also ProjektNR Vorname Name: Steht in IB-ID
For i = 1 To UBound(arr) 'ab hier werden Unikate eingelesen und die zugehötigen Namen und Spalten drangehangangen
For j = 1 To UBound(arr, 2)
If arr(i, j) <> "" Then
varK = arr2(i, 1)
If InStr(D1(varK), arr2(i, 2) & "#" & arr2(i, 3)) = 0 Then
D1(varK) = D1(varK) & "#" & arr2(i, 2) & "#" & arr2(i, 3) & "#" & arr(i, j)
Else
D1(varK) = D1(varK) & "|" & arr(i, j)
End If
End If
Next j
Next i
'ab hier werden Unikat aufgesplitet, Tabellen angelkegt
'und die Namen und Splaten werden in Zellen verteilt
For Each varK In D1.Keys
Set wks = Worksheets.Add(After:=Sheets(Sheets.Count))
wks.Name = Split(varK, "#")(0)
wks.Range("A1:B1").Value = .Range("B1:C1").Value
k = 2
strgText = Replace(D1(varK), "#", "", 1, 1)
For j = 0 To UBound(Split(strgText, "#"))
wks.Cells(k, 1) = Split(strgText, "#")(j)
wks.Cells(k, 2) = Split(strgText, "#")(j + 1)
If UBound(Split(Split(strgText, "#")(j + 2), "|")) > 0 Then
For i = 0 To UBound(Split(Split(strgText, "#")(j + 2), "|"))
wks.Cells(k, 3 + i) = Replace(Cells(1, Val(Split(Split(strgText, "#")(j + 2), "|")(i))).Address(0, 0), "1", "")
Next i
Else
wks.Cells(k, 3) = Replace(Cells(1, Val(Split(strgText, "#")(j + 2))).Address(0, 0), "1", "") 'aus der Sapltenzahl den spaltenbuchstaben ableiten
End If
k = k + 1
j = j + 2
Next j
wks.Range(wks.Cells(1, 3), wks.Cells(1, wks.Range("a1").CurrentRegion.Columns.Count)) = "Fund_Spalte"
Next
End With
Application.DisplayAlerts = False
Application.DisplayAlerts = True
BlattSortierenAuf 'Blätter sortieren
Application.DisplayAlerts = False 'Warnmeldung ausschalten
tmpWks.Delete 'die erstellte Kopie der Datentabelle wird gelöscht
Application.DisplayAlerts = True 'Warnmeldung ein
aktWks.Select 'am Ende wieder Datentabelle auswählen
fehler:
Application.ScreenUpdating = True
Set wks = Nothing
D1.RemoveAll
Set D1 = Nothing
If Err.Number > 0 Then MsgBox Err.Number & " " & Err.Description
End Sub
Zum Löschen der Tabellen wird noch folgender Code gebraucht:
Code:
Sub tab_löschen()
'die in Anführungszeichen stehenden Tabellen werden nicht gelöscht
Dim j As Integer
For j = Sheets.Count To 1 Step -1
If Sheets(j).Name <> "Teilnehmende-Stammdatenblatt" And Sheets(j).Name <> "Tablle2" Then
Application.DisplayAlerts = False
Sheets(j).Delete
Application.DisplayAlerts = True
End If
Next j
End Sub
Und die Tabellen werden nach Erstellung mit folgendem Code sortiert:
Code:
Sub BlattSortierenAuf()
Dim i As Integer
Dim k As Integer
For i = Sheets.Count To 1 Step -1
For k = 1 To i - 1
If Sheets(k).Name > Sheets(k + 1).Name Then 'Absteigend ">" rumdrehem
Sheets(k).Move After:=Sheets(k + 1)
End If
Next
Next
Sheets("Teilnehmende-Stammdatenblatt").Move before:=Sheets(1) 'steht somit immer an erster Stelle
End Sub
Wie Du siehst, habe ich mit der Trickserei aufgehört, und Du solltest den Code jetzt auch anpassen können.
Ich werd die nächste zeit aber noch ein wenig die Beispiele von snb genauer studieren. Mal sehen, vielleicht kann man nachträglich noch
ein Turbo einbauen. Das ist dann aber mehr eine Spielerei für mich um auch ein Gespür für die Dinge zu bekommen.
Ich denke, hier ist Ende mit Drama. :19:
@snb
CEF ist aber hilfsbereit, wenn es geht und wenn der Einzelne Lust und Laune hat.