Brauch dringend Hilfe bei Makro!!!!
19.01.2007 09:54:26
Katharina
ich hab ein paar Makros zusammengematscht um folgende Aufgabe zu lösen:
Es gibt zwei Excel-Dateien:
In der Datei Zentrale.xls werden die ersten drei Spalten (Nr., Thema, Details) gepflegt.
Die Datei Werk.xls übernimmt die Einträge in diesen Spalten, und es werden von anderen Nutzern in den Spalten vier und fünf (Bewertungsampel und begründung) eigene Einträge gemacht, die sich auf die Einträge der ersten drei Spalten beziehen (ein Datensatz je Zeile).
Alle Dateien werden laufend aktualisiert.
In der Datei Zentrale.xls werden Zeilen zwischen bestehenden Datensätzen angelegt und dort neue Datensätze angelegt. Außerdem werden bereits bestehende Datensätze geändert oder ergänzt (z.B. wenn zunächst nur die erste Spalte angelegt wurde).
Die Datei Werk.xls soll beim Öffnen automatisch erkennen, ob eine Aktualisierung stattgefunden hat und wenn ja, jede Aktualisierung von Zentrale.xls übernehmen. Dabei müssen bereits eingetragene Bewertungen in Spalte 4 und 5 zum jeweiligen Thema zugeordnet bleiben (=der Datensatz in einer Zeile bleibt vollständig zusammen).
Mein Makro sieht jetzt folgendermaßen aus:
Option Explicit
Option Compare Text
Public
Function IsFileOpen(ByRef Path As String) As Boolean
Dim FileNr As Integer
Dim ErrorNr As Long
'Datei testweise öffnen:
On Error Resume Next
FileNr = FreeFile
Open Path For Input Lock Write As #FileNr
ErrorNr = Err.Number
Close #FileNr
On Error GoTo 0
'Ggf. Fehler verarbeiten:
Select Case ErrorNr
Case 0 'kein Fehler:
'NOP
Case 70 'Permission denied':
IsFileOpen = True
Case Else 'sonstiger Fehler:
Err.Raise ErrorNr
End Select
End Function
Sub zen_werk()
'Unter der Voraussetzung das in beiden Mappen in den Spalten A nur Zahlen enthalten
'sind und es keine Doppelgänger gibt.
'Natürlich vorläufig nur mit Kopien probieren.
Dim wb1 As Workbook 'Arbeitsmappe zentrale
Dim wb2 As Workbook 'Arbeitsmappe werk
Dim ws1 As Worksheet 'Tabellenblatt 1 zentrale
Dim ws2 As Worksheet 'Tabellenblatt 1 werk
Dim rnga As Range 'Suchrange in Tab Werk Spalte A
Dim lngNr1 As Long 'Zeilenzähler
Dim lngNr2 As Long 'Zeilenzähler
Dim strS1 As String
Dim strS2 As String
Dim path_wb1 As String 'Pfad Zentrale
Dim path_wb2 As String 'Pfad Werk
On Error GoTo errorhandler
'Es fehlt noch die Überprüfung ob die Datei schon geöffnet ist.(Überall im Netz zur finden)
path_wb2 = "O:\TI-50\TI-501\20_Team\Giesguth\Sonstiges\BBM\Test1\Werk.xls" 'Pfad anpassen
Workbooks.Open path_wb2 & "Werk.xls" 'Dateinamen anpassen
strS1 = FileDateTime("O:\TI-50\TI-501\20_Team\Giesguth\Sonstiges\BBM\Test1\Zentrale.xls") ' Pfad und Dateinamen anpassen
Set wb1 = Workbooks("Zentrale.xls")
Set wb2 = Workbooks("Werk.xls")
Set ws1 = wb1.Sheets(1)
Set ws2 = wb2.Sheets(1)
'Wenn die Datei erneut gespeichert wurde, dann
If strS1 <> wb2.Sheets("zeit").Cells(1, 1).Value Then 'Tabellenblatt zeit in der Arbeitsmappe Werk anlegen
path_wb1 = "O:\TI-50\TI-501\20_Team\Giesguth\Sonstiges\BBM\Test1\Zentrale.xls"
Workbooks.Open path_wb1 & "Zentrale.xls"
lngNr1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
lngNr2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
For lngNr1 = 2 To lngNr1
With ws2.Range("A:A")
Set rnga = .Find(ws1.Cells(lngNr1, 1), LookIn:=xlValues)
End With
If Not rnga Is Nothing Then
lngNr2 = rnga.Row
If ws1.Cells(lngNr1, 2).Value <> ws2.Cells(lngNr2, 2).Value Or _
ws1.Cells(lngNr1, 3).Value <> ws2.Cells(lngNr2, 3).Value Then
ws2.Cells(lngNr2, 2).Value = ws1.Cells(lngNr1, 2).Value
ws2.Cells(lngNr2, 3).Value = ws1.Cells(lngNr1, 3).Value
End If
End If
Next
For lngNr1 = 2 To lngNr1
If ws1.Cells(lngNr1, 1).Value <> ws2.Cells(lngNr1, 1).Value Then
ws2.Cells(lngNr1, 1).EntireRow.Insert
ws2.Cells(lngNr1, 1).Value = ws1.Cells(lngNr1, 1).Value
ws2.Cells(lngNr1, 2).Value = ws1.Cells(lngNr1, 2).Value
ws2.Cells(lngNr1, 3).Value = ws1.Cells(lngNr1, 3).Value
End If
Next
wb2.Sheets("zeit").Cells(1, 1).Value = strS1
End If
Set wb1 = Nothing
Set wb2 = Nothing
Set ws1 = Nothing
Set ws2 = Nothing
Set rnga = Nothing
Exit Sub
errorhandler:
Resume
End Sub
Das Problem ist jetzt, dass ich meine fehlermeldungen bezüglich aktualisierung jetzt zwar beseitigt habe, es aber gar keine Aktualisierung mehr stattfindet.
Außerdem besteht seit anfang das Problem, dass in datei zwei keine ganze Zeilen eingefügt werden, sondern nur Spalte 1-3.
Kann mir da irgendwer weiterhelfen? es ist echt wichtig!
P.S.: ich hab die beiden Probedateien mal angehängt.
https://www.herber.de/bbs/user/39770.xls
Die Datei https://www.herber.de/bbs/user/39771.xls wurde aus Datenschutzgründen gelöscht