AW: Daten in neueVorlage übernehmen
08.08.2010 01:39:22
fcs
Hallo Stefan,
das nachfolgende Makro ermöglicht einen entsprechenden Abgleich inklusive Extra-Blätter für Abweichungen.
Das Verzeichnis für die Altdateien muss du natürlich anpassen.
Gruß
Franz
Sub Abgleich_mit_Altdatei()
Dim wbNeu As Workbook, wks_V_Neu As Worksheet, wks_T_Neu As Worksheet
Dim wks_diff As Worksheet, Zeile_Diff As Long, Spalte As Long
Dim vAuswahl, wbAlt As Workbook, wks_V_Alt As Worksheet, wks_T_Alt As Worksheet
Dim Zeile_Alt As Long, vWert_B, Zelle_Wert_B As Range
Dim VerzeichnisAktiv As String
Dim StatusCalc As Long
Const VerzeichnisAlt As String = "C:\Users\Public\Test\Data" 'Verzeichnis mit Alt-Dateien
Set wbNeu = ThisWorkbook
Set wks_V_Neu = wbNeu.Worksheets("V-Zeiten")
Set wks_T_Neu = wbNeu.Worksheets("T-Zeiten")
'Altdatei auswählen
VerzeichnisAktiv = VBA.CurDir 'aktives Verzeichnis merken
VBA.ChDir VerzeichnisAlt 'Verzeichnis mit Alt-Dateien setzen
vAuswahl = Application.Dialogs(xlDialogOpen).Show
If vAuswahl = False Then GoTo Beenden 'Öffnen-Dialog wurde abgebrochen
'Makrobremsen lösen
With Application
.EnableEvents = False
StatusCalc = .Application.Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Set wbAlt = ActiveWorkbook
Set wks_V_Alt = wbAlt.Worksheets("V-Zeiten")
Set wks_T_Alt = wbAlt.Worksheets("T-Zeiten")
'Blätter "V-Zeiten" abgleichen
With wks_V_Alt
For Zeile_Alt = 10 To 100
'Wert in Altdatei-Spalte B
vWert_B = .Cells(Zeile_Alt, 2).Value
If vWert_B "" Then
'Wert in neuer Datei Spalte B suchen
With wks_V_Neu
Set Zelle_Wert_B = .Range(.Cells(10, 2), .Cells(100, 2)) _
.Find(what:=vWert_B, LookIn:=xlValues, lookat:=xlWhole)
End With
If Zelle_Wert_B Is Nothing Then 'Wert in neuer Vorlage nicht vorhanden
If wks_diff Is Nothing Then
'Tabellenblatt für Abweichungen anlegen
Set wks_diff = wbNeu.Worksheets.Add(After:=wks_V_Neu)
wks_diff.Name = "V-Zeiten-Diff"
'Spaltenbreiten in Differenzblatt an Alt-Datei anpassen
For Spalte = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column
wks_diff.Columns(Spalte).ColumnWidth = .Columns(Spalte).ColumnWidth
Next
End If
Zeile_Diff = Zeile_Diff + 1
.Rows(Zeile_Alt).Copy Destination:=wks_diff.Cells(Zeile_Diff, 1)
Else
'Werte aus Spalten E:F von Alt nach Neu kopieren
.Range(.Cells(Zeile_Alt, 5), .Cells(Zeile_Alt, 6)).Copy _
Destination:=wks_V_Neu.Cells(Zelle_Wert_B.Row, 5)
End If
End If
Next
End With
'Blätter "T-Zeiten" abgleichen
Zeile_Diff = 0
Set wks_diff = Nothing
With wks_T_Alt
For Zeile_Alt = 10 To 100
'Wert in Altdatei-Spalte B
vWert_B = .Cells(Zeile_Alt, 2).Value
If vWert_B "" Then
'Wert in neuer Datei Spalte B suchen
With wks_T_Neu
Set Zelle_Wert_B = .Range(.Cells(10, 2), .Cells(100, 2)) _
.Find(what:=vWert_B, LookIn:=xlValues, lookat:=xlWhole)
End With
If Zelle_Wert_B Is Nothing Then 'Wert in neuer Vorlage nicht vorhanden
If wks_diff Is Nothing Then
'Tabellenblatt für Abweichungen anlegen
Set wks_diff = wbNeu.Worksheets.Add(After:=wks_T_Neu)
wks_diff.Name = "T-Zeiten-Diff"
'Spaltenbreiten in Differenzblatt an Alt-Datei anpassen
For Spalte = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column
wks_diff.Columns(Spalte).ColumnWidth = .Columns(Spalte).ColumnWidth
Next
End If
Zeile_Diff = Zeile_Diff + 1
.Rows(Zeile_Alt).Copy Destination:=wks_diff.Cells(Zeile_Diff, 1)
Else
'Werte aus Spalten G:H von Alt nach Neu kopieren
.Range(.Cells(Zeile_Alt, 7), .Cells(Zeile_Alt, 8)).Copy _
Destination:=wks_T_Neu.Cells(Zelle_Wert_B.Row, 7)
End If
End If
Next
End With
'Altdatei wieder schliessen
wbAlt.Close savechanges:=False
'Makrobremsen zurücksetzen
With Application
.EnableEvents = True
.Calculation = StatusCalc
.ScreenUpdating = True
End With
Beenden:
VBA.ChDir VerzeichnisAktiv 'aktives Verzeichnis zurücksetzen
Set wbNeu = Nothing: Set wks_V_Neu = Nothing: Set wks_T_Neu = Nothing
Set wks_diff = Nothing
Set wbAlt = Nothing: Set wks_V_Alt = Nothing: Set wks_T_Alt = Nothing
End Sub