AW: Auszählen von Begriffen in einer Spalte
18.07.2003 09:47:13
Chris (Chrisir)
Hallo !
es gibt hier mehrere Chris', glaube ich.
Naja, hier also meine gestern für Freitag zugesagte Lösung.
Kopiere Deine Tabelle nach Word und lasse folgenden vba-code
darauf anwenden.
Passe ggf. die Zeile Const intMax = 210 an.
210 dürfte zu wenig sein...
Der Makro zählt alle(!) Zellen (also nicht nur die markierten Zellen o.ä.), legt ein neues Word-Doku an, und legt dort die Ergebnisse ab.
Für leere Zeilen verwendet er den Eintrag "nicht erfasst".
An ca. 5 Stellen ist von Ihnen eventuell ein Zeilenumbruch zu entfernen oder Leerzeichen _, also " _" einzufügen (Syntaxfehler).
Rückfragen gerne an mich.
Viele Grüße !
Christoph
Option Explicit
' Dieses Modul zählt Begriffe.
' Ein ganzer Zellinhalt ist ein Begiff.
Const intMax = 210
Dim arrListeDerBegriffe(intMax) As String
Sub TabelleCountBegriffe()
Dim cellMyCell As Cell
Dim strTextDerZelle As String
Dim strBisherVorgekommeneBegriffe As String
Dim arrListeZaehler(intMax) As Integer
Dim intI As Integer
Dim intMyIndex As Integer
Dim strTitelDokument As String
Dim intMyRowNumber As Integer
Dim tblMyTableDestiny As Table
' ggf Abbruch
If Application.Documents.Count <= 0 Then
Exit Sub
End If
' ggf Abbruch
If Application.ActiveDocument.Tables.Count <= 0 Then
MsgBox "Keine Tabelle gefunden."
Exit Sub
End If
' Init (vermutlich überflüssig)
For intI = 1 To intMax
arrListeZaehler(intI) = 0
arrListeDerBegriffe(intI) = ""
Next intI
strBisherVorgekommeneBegriffe = ""
strTitelDokument = ActiveDocument.FullName
intI = 0
For Each cellMyCell In ActiveDocument.Tables(1).Range.Cells
strTextDerZelle = cellMyCell.Range.Text
' Formatieren; -2 wg. Sonderzeichen am Zellenende
strTextDerZelle = Trim(UCase(Left(strTextDerZelle, Len(strTextDerZelle) - 2)))
' Ist Zelle leer?
If Len(strTextDerZelle) < 1 Then
cellMyCell.Range.Text = "nicht erfasst"
' Var neu belegen
strTextDerZelle = cellMyCell.Range.Text
' Formatieren; -2 wg. Sonderzeichen am Zellenende
strTextDerZelle = Trim(UCase(Left(strTextDerZelle, Len(strTextDerZelle) - 2)))
End If
' Enthält die Zelle Text?
If Len(strTextDerZelle) >= 1 Then
' Kam der Begriff schon mal vor?
If InStr(1, strBisherVorgekommeneBegriffe, "#" + strTextDerZelle + "#") <= 0 Then
' neuer Begriff
' neuen Begriff registrieren
strBisherVorgekommeneBegriffe = strBisherVorgekommeneBegriffe + _
"#" + strTextDerZelle + "#"
arrListeDerBegriffe(intI) = strTextDerZelle
intI = intI + 1
' Maximum erreicht?
If intI > intMax Then
intI = intMax
' ggf. Abbruch
If MsgBox("Bereichsüberschreitung für intI", vbInformation + vbOKCancel) _
= vbCancel Then
Exit Sub
End If
End If
Else
' Begriff kam schon mal vor
' tue nichts
End If
' Begriff zählen
intMyIndex = IndexAusBegriff(strTextDerZelle)
arrListeZaehler(intMyIndex) = arrListeZaehler(intMyIndex) + 1
End If
Next cellMyCell
' Ausgabe Ergebnisse neues Dokument **********************************
Documents.Add
Selection.TypeText "Am " & Date & " um " & Time & " aus " & _
strTitelDokument & "." & vbNewLine & vbNewLine
Selection.TypeText strBisherVorgekommeneBegriffe
Selection.TypeText vbNewLine + vbNewLine + vbNewLine + vbNewLine + vbNewLine
Set tblMyTableDestiny = Selection.Tables.Add(Selection.Range, 2, 2)
' fertiges Array ausgeben
intMyRowNumber = 1
' Schleife
For intI = 0 To intMax
If arrListeDerBegriffe(intI) <> "" Then
tblMyTableDestiny.Rows(intMyRowNumber).Cells(1).Range.Text = arrListeDerBegriffe(intI)
tblMyTableDestiny.Rows(intMyRowNumber).Cells(2).Range.Text = arrListeZaehler(intI)
tblMyTableDestiny.Rows(intMyRowNumber).Cells(2).Select
Selection.MoveRight Unit:=wdCell
intMyRowNumber = intMyRowNumber + 1
End If
Next intI
MsgBox "Fertig"
End Sub
Function IndexAusBegriff(strLokalText) As Integer
Dim intLokalI As Integer
For intLokalI = 0 To intMax
If arrListeDerBegriffe(intLokalI) = strLokalText Then
IndexAusBegriff = intLokalI
Exit Function
End If
Next intLokalI
IndexAusBegriff = intLokalI - 1
MsgBox "Nichts gefunden " + strLokalText
End Function