AW: Excel erweitert Dateinamen
07.11.2007 16:51:00
volker
Hai Horst,
um es einigermassen überschaubar zu machen, bei der kursiven Zeile geht die besagte Datei auf
"For Each wsMy In wkbMy.Worksheets "
Danke für Deine Hilfe
Gruss volker
Sub auto_open()
'Zeileneinlesen()
If Cells(2, 5) = 0 Then
Dim unterOdner As Variant, dateien As Variant
Dim oFS As Object, oFLDR As Object, oFILE As Object
Dim lRow As Long
Dim wkbMy As Workbook, wsMy As Worksheet, lngZeile As Long, lngLetzte As Long
' *Prüfe Inhalt ****************************************************************
Set fs = CreateObject("Scripting.filesystemobject")
Set ordner = fs.getfolder("\\Server04\av\SharePoint_Beschlagliste\Pulk")
unterOdner = ordner.subfolders.Count
dateien = ordner.Files.Count
If (dateien * 1) + (unterOdner * 1) = 0 Then
GoTo Abbruch:
End If
Speicher = "SharePoint_Beschlagliste"
Pfad = "\\Server04\av\SharePoint_Beschlagliste"
DName = Speicher
Dateiname = Pfad & "\" & DName & "_" & Date & ".xls"
ThisWorkbook.SaveAs Filename:=Dateiname
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set oFS = CreateObject("scripting.filesystemobject")
lRow = 2
Set oFLDR = oFS.getfolder("\\Server04\av\SharePoint_Beschlagliste\Pulk")
For Each oFILE In oFLDR.Files
If oFILE Like "*.xls" Or oFILE Like "*.xlsm" Or oFILE Like "*.xlsx" Then
lRow = lRow
Set wkbMy = Workbooks.Open(oFILE)
For Each wsMy In wkbMy.Worksheets
If wsMy.Name Like "BL_*" Then
Dim wsMyZeile As Long, wsMyletzte As Long
wsMyletzte = wsMy.Cells(Rows.Count, 1).End(xlUp).Row
For wsMyZeile = 5 To wsMyletzte
If wsMy.Cells(wsMyZeile, 1) "" Then
wsMy.Range("A" & wsMyZeile & ":B" & wsMyZeile).Copy
ThisWorkbook.Worksheets(1).Cells(lRow, 5).PasteSpecial Paste:= _
xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wsMy.Range("G" & wsMyZeile & ":N" & wsMyZeile).Copy
ThisWorkbook.Worksheets(1).Cells(lRow, 7).PasteSpecial Paste:= _
xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wsMy.Range("AA" & wsMyZeile & ":AD" & wsMyZeile).Copy
ThisWorkbook.Worksheets(1).Cells(lRow, 1).PasteSpecial Paste:= _
xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wsMy.Range("AE" & wsMyZeile & ":AF" & wsMyZeile).Copy
ThisWorkbook.Worksheets(1).Cells(lRow, 13).PasteSpecial Paste:= _
xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
lRow = lRow + 1
End If
Next wsMyZeile
End If
Next
wkbMy.Close False
End If
Next
Exit Sub
Abbruch:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ActiveWorkbook.Close
' Application.Quit
End Sub