AW: Datei öffnen, befüllen und speichern
07.10.2008 16:09:50
fcs
Hallo Benny,
der von dir beschriebene Ablauf ist etwas schwierig zu realisieren.
Ich kann dir folgendes anbieten:
Bei einer Änderung in Spalte B wird die Datei "ÄnderungsA.xls" geöffnet und die Daten übertragen.
Solange die Datei "ÄnderungsA.xls" geöffnet ist, werden Änderungen in der gleichen Zeile übertragen.
Per Button-Klick (Button aus Symbolleiste "Steuerelement-Toolbox") wird die datei unter neuem Namen gespeichert.
Den Code muss du in der Datei "CR6Projekt.xls" im VBA-Editor unter der Tabelle speichern, in der die Einagen überwacht werden sollen.
Gruß
Franz
Private wbAenderung As Workbook, wksAenderung As Worksheet, lngZeile As Long
'Nachfolgende Pfade und Dateinamen anpassen
Private Const strPfadAenderung As String = "C:\Lokale Daten\test"
Private Const strDateiAenderung As String = "ÄnderungA.xls"
Private Const strPfad As String = "C:\Lokale Daten\test\Daten" 'Zielverzeichnis für neue _
Dateien
Private Sub CommandButton1_Click()
'Änderungsdatei speichern
On Error GoTo Fehler
If wbAenderung Is Nothing Then
MsgBox "Es wurden noch keine Daten in Spalte B geändert!"
Else
wbAenderung.Activate
If MsgBox(Prompt:="Datei mit Daten zu Zeile " & lngZeile & " speichern?" & vbLf _
& "Dateiname: " & strPfad & "\" & wksAenderung.Range("B8").Text, _
Buttons:=vbYesNo) = vbYes Then
wbAenderung.SaveAs Filename:=strPfad & "\" & wksAenderung.Range("B8").Text
wbAenderung.Close
Set wksAenderung = Nothing
Set wbAenderung = Nothing
Else
ThisWorkbook.Activate
End If
End If
Fehler:
If Err.Number 0 Then
MsgBox "Fehler nr. " & Err.Number & vbLf & Err.Description
ThisWorkbook.Activate
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B6:F60")) Is Nothing And Target.Cells.Count = 1 Then
Select Case Target.Column
Case 2
'Case 2, bei Änderungen eines Werts in Spalte 2, wird Änderungsdatei schreibgeschützt geöffnet _
_
oder neu zugewiesen falls schon geöffnet
If Not IsEmpty(Target) Then
If CheckWorkbookOpen(strDateiAenderung) = True Then
'Änderungsdatei ist schon geöffnet
Set wbAenderung = Workbooks(strDateiAenderung)
Else
'Änderungsdatei schreibgeschützt öffnen
Set wbAenderung = Workbooks.Open(Filename:=strPfadAenderung & "\" & _
strDateiAenderung, _
ReadOnly:=True)
End If
'Tabellenblatt in Änderungsdatei setzen
Set wksAenderung = wbAenderung.Worksheets(1)
ThisWorkbook.Activate
'geänderte Zeile merken
lngZeile = Target.Row
'Daten in Änderungsdatei übertragen
wksAenderung.Range("B8") = Me.Cells(lngZeile, 3)
wksAenderung.Range("D10") = Me.Cells(lngZeile, 4)
wksAenderung.Range("E10") = Me.Cells(lngZeile, 5)
wksAenderung.Range("F10") = Me.Cells(lngZeile, 6)
End If
'Case 3 bis 6 übertragen Änderungen in den Spalten, wenn diese in der gemerkten Zeile erfolgen
Case 3
If Target.Row = lngZeile And Not wbAenderung Is Nothing Then
wksAenderung.Range("B8") = Target.Value
End If
Case 4
If Target.Row = lngZeile And Not wbAenderung Is Nothing Then
wksAenderung.Range("D10") = Target.Value
End If
Case 5
If Target.Row = lngZeile And Not wbAenderung Is Nothing Then
wksAenderung.Range("E10") = Target.Value
End If
Case 6
If Target.Row = lngZeile And Not wbAenderung Is Nothing Then
wksAenderung.Range("F10") = Target.Value
End If
Case Else
'do nothing
End Select
End If
End Sub
Private Function CheckWorkbookOpen(strName As String) As Boolean
'Prüfen, ob Arbeitsmappe strName schon geöffnet ist
Dim wb As Workbook
CheckWorkbookOpen = False
For Each wb In Workbooks
If UCase(wb.Name) = UCase(strName) Then
CheckWorkbookOpen = True
Exit For
End If
Next
End Function