Codevorschlag
12.05.2010 17:57:29
Erich
Hi Micha,
da ich das einfach mal ausprobieren wollte, ´hab ich VOR deiner Antwort mal einen Code geschrieben.
Ob er das tut, was du möchtest, weiß ich nicht. Du kannst es ausprobieren...
Option Explicit
Sub AbkUeber()
Dim lngT As Long, arrT, lngA As Long, arrQ, arrE1(), arrE2()
Dim ii As Long, varV, lngN As Long, zz As Long
Const lngKurz As Long = 2, lngLang As Long = 9 ' Quell- und Zielspalte
With Worksheets("Tab") ' in "Tab" Abk. in Spalte A, Beschr. in Spalte B
lngT = .Cells(.Rows.Count, 1).End(xlUp).Row - 1 ' Abk.-Tabelle einlesen
arrT = .Cells(2, 1).Resize(lngT, 2) ' (1 Zeile Überschrift)
End With
lngA = Cells(Rows.Count, lngKurz).End(xlUp).Row
arrQ = Application.Transpose(Cells(2, lngKurz).Resize(lngA))
ReDim arrE1(1 To lngA), arrE2(1 To lngA)
For ii = 1 To lngA
If IsEmpty(arrQ(ii)) Then ' leere Zelle
ElseIf UCase(arrQ(ii)) = varV Then ' Dublette
Else
lngN = lngN + 1 ' neue Ausgabezeile
varV = UCase(arrQ(ii))
arrE1(lngN) = arrQ(ii) ' Eintrag Quellspalte (Abk.)
For zz = 1 To lngT
If varV = UCase(arrT(zz, 1)) Then
arrE2(lngN) = arrT(zz, 2) ' Eintrag Zielspalte (Beschr.)
Exit For
End If
Next zz
End If
Next ii
If lngN > 0 Then ' Ausgabe
Cells(2, lngKurz).Resize(lngN) = Application.Transpose(arrE1)
Cells(2, lngLang).Resize(lngN) = Application.Transpose(arrE2)
If lngN + 1
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort