AW: kommentar erstellen aus anderer xls
30.01.2007 16:19:17
fcs
Hallo Werner,
hier eine VBA-Lösung. Sie erfordert aber zwingend, dass die 2. Datei mit den Langtexten geöffnet ist, wenn Abkürzungen in der 1. Datei eingetragen werden.
Den Code fügst du im VBA-Editor unter der 1.Datei in der Tabelle ein, in der du die Abkürzungen eingibst.
Gruss
Franz
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim wks As Worksheet
Set wks = Me 'Tabellenblatt in das Kommentare eingefügt werden sollen
Set Bereich = wks.Range("A:A") 'Zellbereich in dem Abkürzungen eingetagen werden
If Not Intersect(Target, Bereich) Is Nothing Then
Call KuerzelKommentarEinfuegen(Target, ActiveWorkbook, "C:\Test\", "Datei2.xls", _
"Tabelle1", "A") 'Angaben zur Datei2 mit den Abkürzungen ggf anpassen
End If
End Sub
Sub KuerzelKommentarEinfuegen(Bereich1 As Range, wb1 As Workbook, _
wb2Pfad As String, wb2Name As String, wb2TabName As String, SpalteAbk As Variant)
Dim wb2 As Workbook, wks2 As Worksheet
Dim Zelle1 As Range, Zelle2 As Range
Application.ScreenUpdating = False
'Prüfung ob Datei mit Abkürzungen und Langtext geöffnet
For Each wb2 In Workbooks
If wb2.Name = wb2Name Then Exit For
Next
If wb2 Is Nothing Then
If MsgBox("Bitte mit OK Datei2.xls öffnen", vbOKCancel, "Abkürzungskommentare") = vbOK Then
Set wb2 = Workbooks.Open(FileName:=wb2Pfad & wb2Name)
wb1.Activate
Else
Exit Sub
End If
End If
Set wks2 = wb2.Worksheets(wb2TabName) 'Tabellenblatt mit Abkürzunge und Langtext
'Abkürzung suchen und Langtext als Kommentar zuweisen
For Each Zelle1 In Bereich1
'Leere Zellen überspringen
If Not IsEmpty(Zelle1) Then
'Abkürzung in Datei2 suchen
Set Zelle2 = wks2.Columns(SpalteAbk).Find(What:=Zelle1.Value, LookIn:=xlValues, Lookat:=xlWhole)
If Zelle2 Is Nothing Then
MsgBox "Abkürzung existiert nicht"
Else
If Zelle1.Comment Is Nothing Then
'Neuer Kommentar wird eingefügt
Zelle1.AddComment.Text Zelle2.Offset(0, 1).Value
Else
'Vorhandener Kommentar wird überschrieben
Zelle1.Comment.Text Zelle2.Offset(0, 1).Value
End If
End If
End If
Next Zelle1
Application.ScreenUpdating = True
End Sub
