AW: Automatisches Einlesen
27.11.2015 01:36:32
Christoph
Hallo,
eventuell so?
Habe nicht viele VBA Kenntnisse, aber vielleicht hilfts ja. Wie das klappen soll mit den nicht doppelten Werten, weiß ich leider nicht. Habe das so gelöst das nach dem zusammenführen Duplikate entfernt werden. Es werden im Moment nur Komplett gleiche Zeilen gelöscht, da ich nicht wusste ob du das so meinst, oder ob jede einzelne Zelle kontrolliert werden muss.
In der 3. letzten Zeile werden noch alle .xlsx Dateien im Ordner Export gelöscht wenn du das Hochkomma entfernst.
Gespeichert wird die Datei und Import und den aktuellen Datum.
Hoffe konnte helfen.
Gruß
Christoph
Const strPath As String = "C:\export\" 'Pfad eventuell anpassen
Sub Main()
Dim strDateiname As String
Dim wkbBook As Workbook
Dim lngLastRowQ As Long
Dim lngLastRowZ As Long
Dim lngLastCol As Long
Dim intCalc As Integer
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
intCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
'strDateiname = Dir$(ThisWorkbook.Path & "\*.xls")
strDateiname = Dir$(strPath & "*.xlsx")
Do While strDateiname ""
If strDateiname ThisWorkbook.Name Then
Set wkbBook = Workbooks.Open(strPath & strDateiname)
Call Bearbeiten
wkbBook.Close False ' Oder True, wenn gespeichert werden soll
Set wkbBook = Nothing
End If
strDateiname = Dir$()
Loop
Fin:
Set wkbBook = Nothing
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = intCalc
.DisplayAlerts = True
End With
If Err.Number 0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
Application.DisplayAlerts = False
Windows("Import.xlsm").Activate
Columns("A:Z").Select
Range("Z1").Activate
ActiveSheet.Range("$A$1:$Z$2000").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, _
8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26), Header:= _
xlYes
'Kill "C:\export\*.xlsx"'Pfad eventuell anpassen
ActiveWorkbook.SaveAs Filename:="C:\export\Archiv\Import-" & Date & ".xlsx, FileFormat:= _
xlOpenXMLWorkbook, Local:=True" 'Pfad eventuell anpassen
Application.DisplayAlerts = True
End Sub
Sub Bearbeiten()
Rows("1:1").Select
Selection.Copy
Windows("Import.xlsm").Activate
Range("A65536").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub