AW: bitte wer anders, weil...
13.12.2013 08:23:44
Detlef
Hallo,
okay hier der Code:
Public verz As String
Public xlsName As String
Sub Initialisieren()
verz = ThisWorkbook.Path
xlsName = ThisWorkbook.Name
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("Start").Select
Range("A3").Select
Application.DisplayAlerts = False 'Meldungen aus
'Application.ScreenUpdating = False 'Screen Update aus
MsgBox "Initialisierung erfolgreich"
End Sub
Sub DateienAuflisten()
Dim i As Long
Dim Bereich As Range
Dim Zelle As Range
Dim dateinameohnepfad As String
Application.DisplayAlerts = False
Import = verz & "\daten\" 'Verzeichnis das durchsucht wird
ChDir verz
Call loeschen
Windows(xlsName).Activate
With Application.FileSearch
.NewSearch
.LookIn = Import
.SearchSubFolders = False
.FileType = msoFileTypeAllFiles
.Execute
For i = 1 To .FoundFiles.Count
dateinameohnepfad = Mid(.FoundFiles(i), InStrRev(.FoundFiles(i), "\") + 1) 'Verzeichnisse _
entfernen
Sheets("Import").Select
Cells(65000, 1).End(xlUp).Offset(1, 0).Select
Workbooks.Open Filename:= _
Import & dateinameohnepfad
Range("A25").Select
If ActiveCell.Value "" Then
Range("A8:A25").Select
Selection.Copy
Else
Range("A8:A13").Select
Selection.Copy
End If
Windows(xlsName).Activate 'Dateiname
ActiveSheet.Paste
Windows(dateinameohnepfad).Activate
ActiveWorkbook.Close
Sheets("Daten").Select
Cells(65000, 1).End(xlUp).Offset(1, 0).Select
ActiveCell.Value = dateinameohnepfad
Next i
Sheets("Import").Select
Selection.AutoFilter Field:=2, Criteria1:="GND1"
Selection.AutoFilter Field:=3, Criteria1:="NCG"
Range(Cells(2, 2), Cells(65536, 5).End(xlUp)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("NCG").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A2").Select
Sheets("Import").Select
Selection.AutoFilter Field:=2, Criteria1:="GND1"
Selection.AutoFilter Field:=3, Criteria1:="GPL"
Range(Cells(2, 2), Cells(65536, 5).End(xlUp)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("GPL").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A2").Select
Sheets("Import").Select
Selection.AutoFilter Field:=2, Criteria1:="GND1"
Selection.AutoFilter Field:=3, Criteria1:="TTF"
Range(Cells(2, 2), Cells(65536, 5).End(xlUp)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("TTF").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A2").Select
Call format
Call sortieren
Sheets("Start").Select
Range("A2").Select
End With
End Sub
Sub format()
' Datenformate aktualisieren
Sheets("NCG").Select
Columns("D:D").Select
Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns("C:C").Select
Selection.TextToColumns Destination:=Range("C1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
Columns("D:D").Select
Selection.TextToColumns Destination:=Range("D1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(0, 1), TrailingMinusNumbers:=True
Sheets("TTF").Select
Columns("D:D").Select
Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns("C:C").Select
Selection.TextToColumns Destination:=Range("C1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
Columns("D:D").Select
Selection.TextToColumns Destination:=Range("D1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(0, 1), TrailingMinusNumbers:=True
Sheets("GPL").Select
Columns("D:D").Select
Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns("C:C").Select
Selection.TextToColumns Destination:=Range("C1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
Columns("D:D").Select
Selection.TextToColumns Destination:=Range("D1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(0, 1), TrailingMinusNumbers:=True
End Sub
Sub sortieren()
'Daten nach Datum Sortieren
Sheets("NCG").Select
Range(Cells(2, 1), Cells(65536, 4).End(xlUp)).Select
Selection.Sort Key1:=Range("C2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Sheets("TTF").Select
Range(Cells(2, 1), Cells(65536, 4).End(xlUp)).Select
Selection.Sort Key1:=Range("C2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Sheets("GPL").Select
Range(Cells(2, 1), Cells(65536, 4).End(xlUp)).Select
Selection.Sort Key1:=Range("C2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub
Sub loeschen()
Windows(xlsName).Activate 'Dateiname
Sheets("Daten").Select
Range("A:A").ClearContents
Sheets("Import").Select
Selection.AutoFilter Field:=1 'Filter zum löschen zurücksetzen
Selection.AutoFilter Field:=2
Selection.AutoFilter Field:=3
Selection.AutoFilter Field:=4
Selection.AutoFilter Field:=5
Range("A:A").ClearContents
Sheets("NCG").Select
Range("A:D").ClearContents
Sheets("GPL").Select
Range("A:D").ClearContents
Sheets("TTF").Select
Range("A:D").ClearContents
End Sub
An den jeniger der es schafft, herzlichen Dank vorab!!