Update funktion

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub Datei_vorhanden() Dim Pfad As String Dim Fso, DateiName Set Fso = CreateObject("Scripting.FileSystemObject") Pfad = "C:\....\2009\" ' Hier deinen Pfad vorgeben DateiName = Pfad & "\" & ActiveSheet.Name & ".xls" If Fso.FileExists(DateiName) Then Workbooks.Open DateiName Else MsgBox "nichts da!" End If End Sub

Sub Tabellen_Vergleich07() '* H. Ziplies * '* 02.06.07 * '* erstellt von HajoZiplies@web.de * '* http://Hajo-Excel.de/ Dim WbO As Worksheet ' Original Datei Dim WbK As Worksheet ' Kopie Datei Dim LoI As Long ' 1. Schleifenvariable Dim LoJ As Long ' 2. Schleifenvariable Dim LoLetzte1 As Long ' Variable letzte Zeile in _ Spalte A Dim LoLetzte2 As Long ' Variable letzte Zeile in _ Spalte B Application.ScreenUpdating = False ' Bildschirmaktualisierung aus Set WbO = ActiveSheet Set WbK = Workbooks("Tuesday 45.xls").Worksheets("Tuesday 45") With WbO ' letzte belegte Zeile unabhängig von Excelversion für Spalte D (4), es wird davon _ ausgegangen, dass keine Zeilen ausgeblendet sind LoLetzte1 = IIf(IsEmpty(.Cells(Rows.Count, 4)), .Cells(Rows.Count, 4).End(xlUp).Row, . _ Rows.Count) End With With WbK ' letzte belegte Zeile unabhängig von Excelversion für Spalte D (4), es wird davon _ ausgegangen, dass keine Zeilen ausgeblendet sind LoLetzte2 = IIf(IsEmpty(.Cells(Rows.Count, 1)), .Cells(Rows.Count, 1).End(xlUp).Row, . _ Rows.Count) End With For LoI = 1 To LoLetzte1 ' 1. Schleife alle Werte Spalte _ D Original For LoJ = 1 To LoLetzte2 ' 2. Schleife alle Werte Spalte _ A Kopie If WbO.Cells(LoI, 1) "" Then ' Leerzellen nicht kennzeichnen If WbO.Cells(LoI, 1) = WbK.Cells(LoJ, 2) Then WbO.Cells(LoI, 74) = WbK.Cells(LoJ, 7) End If End If Next LoJ Next LoI Set WbO = Nothing ' Variable leeren Set WbK = Nothing ' Variable leeren Application.ScreenUpdating = True ' Bildschirmaktualisierung ein End Sub

Hallo Chris,
um es deutlicher zu machen, sagen wir ich hab die update datei die an einem fixen Ort gespeichert ist und ich hab die Datei in der ich arbeite sagen wir die heißt Planung.
Uberigens möchte ich den Code als Addin speichern, ich weiß nicht in wie weit es relevant ist.
Zu 2.: er soll aus der Update Datei jede Zeile durchlaufen, angefangen bei Zeile 2 also Zelle F2. Den Wert soll er in Spalte F in der Datei Planung suchen, wenn er den Wert findet, dann soll er x2, y2, z2 aus Update-Datei nehmen und in Zelle x2, y2, z2 bei Planung reinkopieren (sind natuerlich jetzt ausgedachte Zellen die ich später anpassen werde.
Zu 3.: Wenn er den Wert nicht findet, dann soll er die komplette Zeile von Update in Planung kopieren und zwar ans Ende
Zu.4.: Das soll er für alle Zeilen machen in Update. Also als nächstes F3, suchen ob er den Wert in der Datei Planung, Spalte F findet, wenn ja kopiere von Update datei xyz3 in Datei Planung natürlich auch xyz3.
Eine Zeile ist immer ein Fall und die Daten von Update werden immer nach Planung kopiert, nie umgekehrt.
Gruß Abu

Sub ABU() Dim Pfad As String, WksZiel As Worksheet, WksQuelle As Worksheet Dim Fso, DateiName, i Dim rSuche As Range, rFinde As Range Set Fso = CreateObject("Scripting.FileSystemObject") Set WksZiel = ThisWorkbook.ActiveSheet Pfad = "C:\....\2009\" ' Hier deinen Pfad vorgeben DateiName = Pfad & "\" & ActiveSheet.Name & ".xls" Application.ScreenUpdating = False If Fso.FileExists(DateiName) Then Workbooks.Open DateiName Else MsgBox "nichts da!" Application.ScreenUpdating = True Exit Sub End If Set WksQuelle = ActiveWorkbook.ActiveSheet 'Suche in Planungsdatei nach den einzelnen _ Werten aus Spalte F von der geöffneten Datei With WksZiel Set rFinde = .Range("F:F") For i = 2 To WksQuelle.Cells(65536, 6).End(xlUp).Row Set rSuche = rFinde.Find(what:=WksQuelle.Cells(i, 6), LookAt:=xlWhole, LookIn:= _ xlValues) If Not rSuche Is Nothing Then ' wenn da , werte ersetzen .Range("X" & rSuche.Row) = WksQuelle.Range("X" & i) .Range("Y" & rSuche.Row) = WksQuelle.Range("Y" & i) .Range("Z" & rSuche.Row) = WksQuelle.Range("Z" & i) Else WksQuelle.Rows(i).Copy .Cells(.Cells(65536, 6).End(xlUp).Row, 1) ' sonst zeile _ kopieren End If Next i End With With WksZiel Set rFinde = WksQuelle.Range("F:F") ' Suche in Update in Spalte F, ob alle Einträge _ aus Planung vorhanden For i = .Cells(65536, 6).End(xlUp).Row To 2 Step -1 Set rSuche = rFinde.Find(what:=.Cells(i, 6), LookAt:=xlWhole, LookIn:=xlValues) If rSuche Is Nothing Then ' wenn nicht lösche in Planung die entsprechende Zeile .Rows(i).EntireRow.Delete End If Next i End With Set rFinde = Nothing Set rSuche = Nothing Application.ScreenUpdating = True End Sub

Servus,
ich hab übrigens einen kleinen Fehler entdeckt:

Sub ABU()
Dim Pfad As String, WksZiel As Worksheet, WksQuelle As Worksheet
Dim Fso, DateiName, i
Dim rSuche As Range, rFinde As Range
Set Fso = CreateObject("Scripting.FileSystemObject")
Set WksZiel = ThisWorkbook.ActiveSheet
Pfad = "C:\....\2009\" ' Hier deinen Pfad vorgeben
DateiName = Pfad & "\" & ActiveSheet.Name & ".xls"
Application.ScreenUpdating = False
If Fso.FileExists(DateiName) Then
Workbooks.Open DateiName
Else
MsgBox "nichts da!"
Application.ScreenUpdating = True
Exit Sub
End If
Set WksQuelle = ActiveWorkbook.ActiveSheet 'Suche in Planungsdatei nach den einzelnen  _
Werten aus Spalte F von der geöffneten Datei
With WksZiel
Set rFinde = .Range("F:F")
For i = 2 To WksQuelle.Cells(65536, 6).End(xlUp).Row
Set rSuche = rFinde.Find(what:=WksQuelle.Cells(i, 6), LookAt:=xlWhole, LookIn:= _
xlValues)
If Not rSuche Is Nothing Then ' wenn da , werte ersetzen
.Range("X" & rSuche.Row) = WksQuelle.Range("X" & i)
.Range("Y" & rSuche.Row) = WksQuelle.Range("Y" & i)
.Range("Z" & rSuche.Row) = WksQuelle.Range("Z" & i)
Else
WksQuelle.Rows(i).Copy .Cells(.Cells(65536, 6).End(xlUp).Row + 1, 1) ' hier hat  _
ein + 1 gefehlt
End If
Next i
End With
With WksZiel
Set rFinde = WksQuelle.Range("F:F") ' Suche in Update in Spalte F, ob alle Einträge   _
_
aus Planung vorhanden
For i = .Cells(65536, 6).End(xlUp).Row To 2 Step -1
Set rSuche = rFinde.Find(what:=.Cells(i, 6), LookAt:=xlWhole, LookIn:=xlValues)
If rSuche Is Nothing Then ' wenn nicht lösche in Planung die entsprechende Zeile
.Rows(i).EntireRow.Delete
End If
Next i
End With
Set rFinde = Nothing
Set rSuche = Nothing
Application.ScreenUpdating = True
End Sub

hier nochmal der Abschnitt der fehlerhaft war:
Else
WksQuelle.Rows(i).Copy .Cells(.Cells(65536, 6).End(xlUp).Row + 1, 1) ' hier hat ein + 1 gefehlt
End If
ohne das +1 kopiert er immer in die letzte beschriebene Zeile. Ich hab das in obigem Makro bereits verbessert.
Gruß
Chris

Beliebteste Forumthreads (12 Monate)

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread