Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1224to1228
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Kreuztabelle füllen

Kreuztabelle füllen
ptonka
Hallo zusammen,
ich habe ein Problem bzgl. des Befüllens einer Kreuztabelle (so heisst auch das Tabellenblatt).
Folgende Situation:
In Spalte A stehen Usernamen (A2:A19000) - In Zeile 1 stehen Softwareprofile (A1: BNN1).
Es sind also 19.000 User und ca. 14.500 Softwareprofile.
In einer Anderen Tabelle ("Grunddaten") stehen 250.000 Datensätze in Spalte D die sich aus
dem Username und dem Softwareprofil zusammensetzen (Kombination).
Beispiel: Username = willi0001 Softwareprofil = S01_Excel2010 Kombi = willi0001S01_Excel2010
In der Kreuztabelle soll nun in dem Kreuzungsfeld von Zeile willi0001 und der Spalte S01_Excel2010
ein "X" gesetzt werden.
Ich habe dies mit folgenden 2 (zugegebenermaßen laienhaften) Makros realisiert:
Public Kombi, Gefunden As String
Sub Kreuze()
Sheets("Kreuztabelle").Select
For Z = 2 To 19424
Sheets("Kreuztabelle").Select
User = Cells(Z, 1).Value
For S = 2 To 1448
Profil = Cells(1, S).Value
Kombi = User & Profil
Gefunden = ""
Call Suche
Sheets("Kreuztabelle").Select
Select Case Gefunden
Case Is = "JA"
Cells(Z, S).Value = "X"
End Select
Next S
Next Z
End Sub

Sub Suche()
Sheets("Daten").Select
On Error GoTo weiter
Cells.Find(What:=Kombi, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Gefunden = "JA"
GoTo ende
weiter:
Gefunden = "Nein"
ende:
End Sub

Dies läuft aber aufgrund der hohen Datenmenge unendlich langsam bzw. lange.
Wie kann ich meine Anforderung entsprechend tunen, so dass ich schnell eine mit "X"-en
ausgefüllte Kreuztabelle erhalte?
Danke im Voraus für diverse Tipps.
Gruß,
Ptonka

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
Kombinationen per MATCH suchen und Kreuz eintragen
18.08.2011 10:38:31
NoNet
Hallo Ptonka,
die Performance geht durch die VBA-Schleifen erheblich in die Knie.
Mein Vorschlag : Fülle den Bereich im Blatt "Kreuztabelle" per VBA mit der passenden Excelfunktion und kopiere anschliessend die resultierenden Werte in diesen Bereich.
ACHTUNG : Durch den riesigen Bereich scheint Excel zu "hängen" und bremst den PC aus !
Sichere daher zuvor alle Daten aus allen Anwendungen (auch die Excelmappe selbst !), falls es zu lange dauert, musst Du den Task evtl. abschiessen. Aber gedulde Dich zuvor ein wenig ! Ich habe das mit Excel 2003 (also : max. 65536 Zeilen und 256 Spalten) getestet : Für ca. 3 Min. erschien im Taks-Manager die Meldung "Keine Rückmeldung", aber letztendlich klappte es !!
Sub SoftwareSuchen()
With Sheets("Kreuztabelle").Range("B2:IV19424")
'Bereiche IV19424 und  $D$65536 bitte anpassen !
.Formula = "=IF(ISNUMBER(MATCH($A2&B$1,Grunddaten!$D$2:$D$65536,0)),""x"","""")"
.Copy
.PasteSpecial xlValues
End With
[A1].Select
End Sub
Gruß, NoNet
Exceltreffen 28.-30.10.2011 in Chemnitz
Ein Treffen für alle Excel-Freunde und Besucher deutschsprachiger Excel-Foren.
Alle Infos - Programm - Anmeldung - Teilnehmerliste etc. gibt es auf
http://www.exceltreffen.de/index.php?page=211
Wir freuen uns auf euch...

Anzeige
Kreuztabelle füllen - viele Daten
19.08.2011 08:10:43
Erich
Hi,
probier mal diesen Code (den Massentest habe ich nicht gemacht...):

Sub KreuzTab()
Dim lngU As Long, lngP As Long, lngK As Long
Dim arrU, arrP, arrK, arrE()
Dim kk As Long, zz As Long, ss As Long, nn As Long
With Sheets("Daten")
lngK = .Cells(Rows.Count, 4).End(xlUp).Row
arrK = .Cells(1, 4).Resize(lngK)
End With
With Sheets("Kreuztabelle")
.Select
lngU = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
arrU = .Cells(2, 1).Resize(lngU)
lngP = .Cells(1, .Columns.Count).End(xlToLeft).Column - 1
arrP = .Cells(1, 2).Resize(, lngP)
ReDim arrE(1 To lngU, 1 To lngP)
For kk = 1 To lngK
For zz = 1 To lngU
nn = Len(arrU(zz, 1))
If arrK(kk, 1) Like arrU(zz, 1) & "*" Then
For ss = 1 To lngP
If arrK(kk, 1) = arrU(zz, 1) & arrP(1, ss) Then _
arrE(zz, ss) = arrE(zz, ss) + 1
Next ss
End If
Next zz
Next kk
.Cells(2, 2).Resize(lngU, lngP) = arrE
End With
End Sub
Statt arrE(zz, ss) = arrE(zz, ss) + 1 kannst du natürlich arrE(zz, ss) = "X" schreiben.
Hier funzt es: https://www.herber.de/bbs/user/76242.xlsm
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige