AW: versuchen wir es mal so ...
13.11.2015 15:53:03
Tino
Hallo,
dann sind wir bis auf die Spalten wieder beim alten Code.
Weil wenn der Datensatz gleich ist mit dem bereits vorhandenen brauchen wir
diesen auch nicht zu aktualisieren.
Ersetzen den gesamten Code im Modul1 durch diesen.
Option Explicit
Sub Start()
Dim sPath$, NextRow&, FarbeNeu&
Dim ExWB As Workbook, ExWS As Worksheet, ExRng As Range
Dim aktRange As Range, booCopyHeader As Boolean, tmpArCol()
Const AnzahlSpalten& = 7 'Anzahl der Spalten
FarbeNeu = RGB(255, 0, 0) 'Farbe für neue Daten
sPath = FileAuswahl(ThisWorkbook.Path, Excel_File_XLSX)
If sPath = "" Then Exit Sub
On Error GoTo ErrorHandler:
Call Events_(False)
With ActiveSheet
Application.Goto .Cells(2, 1), True
Set aktRange = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, AnzahlSpalten)
If aktRange.Rows(1).Row = 1 Then
booCopyHeader = True
NextRow = 1
Else
aktRange.Interior.Color = xlNone
End If
End With
Set ExWB = Workbooks.Open(sPath, ReadOnly:=True)
For Each ExWS In ExWB.Worksheets
If booCopyHeader Then
With ExWS
.Calculate
Set ExRng = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, AnzahlSpalten)
If ExRng.Rows(1).Row > 1 Then 'Daten vorhanden
If booCopyHeader And NextRow = 1 Then
.Range("A1").Resize(, 7).Copy aktRange.Parent.Cells(1, 1)
End If
With aktRange.Parent
NextRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
ExRng.Copy .Cells(NextRow, 1)
End With
End If
End With
Else
With ExWS
Set ExRng = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, AnzahlSpalten)
If ExRng.Rows(1).Row > 1 Then 'Daten vorhanden
With aktRange.Parent
NextRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
ExRng.Copy .Cells(NextRow, 1)
With .Cells(NextRow, 1).Resize(ExRng.Rows.Count, AnzahlSpalten)
.Interior.Color = FarbeNeu
.Value = .Value
End With
End With
End If
End With
End If
Next ExWS
ExWB.Close False
Set ExWB = Nothing
With ActiveSheet
Redim tmpArCol(AnzahlSpalten - 1)
For NextRow = 0 To AnzahlSpalten - 1
tmpArCol(NextRow) = NextRow + 1
Next NextRow
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, AnzahlSpalten)
.RemoveDuplicates Columns:=(tmpArCol), Header:=xlYes
End With
End With
ErrorHandler:
If Not ExWB Is Nothing Then ExWB.Close False: Set ExWB = Nothing
Call Events_(True)
If Err.Number <> 0 Then
ActiveSheet.Columns(ActiveSheet.Columns.Count).Delete
MsgBox Err.Description, _
vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
"Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If
End Sub
Sub Events_(booSchalter As Boolean)
With Application
.ScreenUpdating = booSchalter
.DisplayAlerts = booSchalter
.EnableEvents = booSchalter
.Calculation = IIf(booSchalter, xlCalculationAutomatic, xlCalculationManual)
End With
End Sub
Gruß Tino