AW: Import nach 2 Kriterien
21.06.2008 16:54:00
fcs
Hallo Maris,
auch ein Kommentar kann zusammen mit den Werten aus dem Importblatt übertragen werden.
Ich hab das Makro angepasst.
Wenn für das Konto im Blatt Import ein Kommentar in der Spalte 3 (diese kannst du auch anders festlegen) eingetragen ist, dann wird der Kommentar ebenfalls in das Blatt Daten übertragen.
Ist für das Konto an dem Tag im blatt Daten schon ein Kommentar eingetragen, dann wird der neue Kommentar vor dem vorhandenen eingefügt. Zusätzlich wird das Datum des Imports vor dem Kommentar eingetragen.
Gruß
Franz
Sub ImportNachDaten()
Dim wksDaten As Worksheet, wksImport As Worksheet
Dim datDatum As Date, bolDatum As Boolean
Dim varKonto As Variant, dblBewegung As Double, lngImport As Long
Dim lngSpalte As Long, objZelle As Range
Dim bolKommentar As Boolean, strKommentar As String, objComment As Comment
Set wksDaten = Worksheets("Daten")
Set wksImport = Worksheets("Import")
Const lngSpalteKommentar As Long = 3 'Spalte im Blatt Import mit Kommentaren
'Datum im Blatt Import einlesen
datDatum = wksImport.Range("B1")
'Sicherheitsabfrage ob Aktion ausgeführt werden soll
If MsgBox(Prompt:="Wollen sie Daten für den " & Format(datDatum, "DD.MM.YYYY") _
& " aus dem Blatt Import nach Daten übertragen?", _
Buttons:=vbOKCancel, Title:="Daten von Import ---> Daten") = vbCancel _
Then GoTo Beenden
With wksDaten
'Spalte mit Datum im Blatt Daten ermitteln
For lngSpalte = 5 To .Cells(3, .Columns.Count).End(xlToLeft).Column
If .Cells(3, lngSpalte).Value = datDatum Then
bolDatum = True
Exit For
End If
Next
If bolDatum = False Then
MsgBox "Datum " & Format(datDatum, "DD.MM.YYYY") _
& " in Blatt Daten Zeile 3 nicht gefunden!"
Else
'zeilen im Blatt Import abarbeiten
For lngImport = 3 To wksImport.Cells(wksImport.Rows.Count, 1).End(xlUp).Row
varKonto = wksImport.Cells(lngImport, 1).Value 'Konto-Nr
dblBewegung = wksImport.Cells(lngImport, 3).Value 'Bewegungsumme
'prüfen, ob für Konto ein Kommentar in Spalte "Bewegung" vorhanden ist
bolKommentar = False
With wksImport.Cells(lngImport, lngSpalteKommentar)
If Not .Comment Is Nothing Then
bolKommentar = True
'Kommentartext zwischenspeichern
strKommentar = .Comment.Text
End If
End With
'Konto in Spalte 3 Blatt Daten suchen
Set objZelle = .Columns(3).Find(What:=varKonto, LookIn:=xlValues, lookat:=xlWhole)
If objZelle Is Nothing Then
MsgBox "Konto " & varKonto & " in Blatt Daten Spalte 3 nicht gefunden!"
Else
.Cells(objZelle.Row, lngSpalte).Value = .Cells(objZelle.Row, lngSpalte).Value _
+ dblBewegung
If bolKommentar = True Then
'Kommentar für Konto zum Datum setzen
Set objComment = .Cells(objZelle.Row, lngSpalte).Comment
If objComment Is Nothing Then
'Im Blatt Daten ist für Konto am Tag noch kein Kommentar vorhanden
'Kommentar aus Blatt Import kopieren
wksImport.Cells(lngImport, lngSpalteKommentar).Copy
.Cells(objZelle.Row, lngSpalte).PasteSpecial Paste:=xlPasteComments
Application.CutCopyMode = False
Set objComment = .Cells(objZelle.Row, lngSpalte).Comment
Else
With objComment
'neue Kommentarzeile(n) vor dem vorhandenen Kommentar einfügen
.Text Text:=strKommentar & Chr(10), Start:=1, overwrite:=False
'eingefügten Kommentar nicht fett formatieren
.Shape.TextFrame.Characters(1, Len(strKommentar) + 1).Font.Bold = False
End With
End If
With objComment
'Aktuelles Datum vor dem Kommentar einfügen
.Text Text:=Format(Date, "YYYY-MM-DD "), Start:=1, overwrite:=False
'Datum fett formatieren
.Shape.TextFrame.Characters(1, 10).Font.Bold = True
End With
End If
End If
Next
End If
End With
Beenden:
Set wksDaten = Nothing: Set wksImport = Nothing: Set objZelle = Nothing
Set objComment = Nothing
End Sub