Abkürzungen werden durch Makro
14.11.2008 15:27:00
Ingo
ich hatte Hilfe bei der Programmierung (Danke Peter) einer Funktion bekommen:
https://www.herber.de/forum/archiv/1020to1024/t1022665.htm
Leider kann ich die Formeln nicht anpassen:
- Meine Tabellennamen sind DATA und ZIEL, konnte ich ändern.
- Die Reihenfolge der Abkürzungen beginnt erst in Zeile 4, ging ebenfalls.
- Die Langtexte sollen in ZIEL in Spalte N ab Zeile 13 geschrieben werden.
- Die Abkürzungen stehen in ZIEL ab O13:O
- In DATA sind die drei Spalten gleich angelegt. Die Überschrift ist in Zeile 3 (=Abkürz., Langtext, Pos.), die Inhalte ab Zeile 4
> Ich bekomme die Fehlermeldung "Index außerhalb des gültigen Bereichs."
> Was bedeutet bitte "rows.count?
Hier nun meine Anpassung:
Option Explicit
'
' Ich habe Abkürzungen in einer Zelle in Spalte A.
' In einer anderen Zelle (Spalte B) möchte ich gerne die ausgeschriebenen Wörter
' in korrekter Reihenfolge darstellen lassen:
'
' In dem zweiten Bereich habe ich eine Reihenfolge der Abkürzungen zu ausgeschriebenen
' Texten.
'
Public Sub Klartext()
Dim WkSh_Q As Worksheet ' das Quell-Tabellenblatt - mit den Kürzeln und dem Langtext
Dim WkSh_Z As Worksheet ' das Ziel-Tabellenblatt - mit den Eingaben und den Ausgaben
Dim aTemp As Variant ' ein temporerer Array für die Eingaben
Dim iIndx As Integer ' der For/Next Index zum temporären Array
Dim lZeile As Long ' For/Next Zeilen-Index zum Eingaben-Tabellenblatt
Dim aLngTxt As Variant ' ein Arbeits-Array für die Langtext-Ausgabe
Dim iLngMax As Integer ' die maximale Position der Langtexte
Dim rZelle As Range ' die Zelle mit den gesuchten Kürzeln zum vorgegebenen Kürzel
Application.ScreenUpdating = False ' kein Bildschirm-Update - kein flackern
Set WkSh_Q = ThisWorkbook.Worksheets("Data") ' den Blattnamen für Quelle anpassen
Set WkSh_Z = ThisWorkbook.Worksheets("Ziel") ' den Blattnamen für Ziel anpassen
iLngMax = Application.WorksheetFunction.Max(WkSh_Q.Range("C4:C" & _
WkSh_Q.Cells(Rows.Count, 3).End(xlUp).Row)) ' die maximale Zuordnung/Reihenfolge
WkSh_Z.Range("N13:N" & WkSh_Z.Cells(Rows.Count, 14).End(xlUp).Row).ClearContents ' 14 statt _
_
_
2
With WkSh_Z
For lZeile = 13 To .Cells(Rows.Count, 1).End(xlUp).Row ' rows.count 15 statt 1 ?
aTemp = Split(.Cells(lZeile, 15).Value, " ") ' die Eingaben am Space trennen; _
Startzelle Zeile=lZeile; Spalte=15=N
ReDim aLngTxt(iLngMax) ' den Arbeits-Array für die Langtexte redimensionieren
For iIndx = LBound(aTemp) To UBound(aTemp) ' den temporären Array abarbeiten
With WkSh_Q.Range("A4:A" & WkSh_Q.Cells(Rows.Count, 1).End(xlUp).Row)
Set rZelle = .Find(aTemp(iIndx), LookAt:=xlWhole, LookIn:=xlValues)
If Not rZelle Is Nothing Then ' das Kürzel wurde gefunden
If aLngTxt(CInt(WkSh_Q.Cells(rZelle.Row, 3).Value) - 1) = "" Then
aLngTxt(CInt(WkSh_Q.Cells(rZelle.Row, 3).Value) - 1) = _
WkSh_Q.Cells(rZelle.Row, 2).Value
Else
aLngTxt(CInt(WkSh_Q.Cells(rZelle.Row, 3).Value) - 1) = _
aLngTxt(CInt(WkSh_Q.Cells(rZelle.Row, 3).Value) - 1) & " " & _
WkSh_Q.Cells(rZelle.Row, 2).Value
End If
Else
MsgBox "Das Kürzel """ & aTemp(iIndx) & """ wurde nicht gefunden.", _
48, " Hinweis für " & Application.UserName
End If
End With
Next iIndx
For iIndx = LBound(aLngTxt) To UBound(aLngTxt)
If WkSh_Z.Cells(lZeile, 14).Value = "" Then ' 14 statt 2, da N=14?
If aLngTxt(iIndx) "" Then WkSh_Z.Cells(lZeile, 14).Value = aLngTxt(iIndx) ' _
_
_
14 statt 2
Else
If aLngTxt(iIndx) "" Then WkSh_Z.Cells(lZeile, 14).Value = _
WkSh_Z.Cells(lZeile, 14).Value & " " & aLngTxt(iIndx) ' 14 statt 2
End If
Next iIndx
Next lZeile
End With
Application.ScreenUpdating = False
End Sub
Viele Grüße
Ingo