Nochmal XL4 für Erich G.

Sub Kopie_aus_Mappen() Dim strFile As String Dim intSpZ%, intSp% Dim wks As Worksheet, ii%, lngLast& ' Vorgaben Const strVerz = "c:\umsatz" ' Quellverzeichnis ' Const strVerz = "f:\exc\w-w-w\tmp\rainer" ' Quellverzeichnis Const lngZeQ = 16 ' Zeile mit Überschriften in Quelldateien Const intSpQ = 4 ' 1. mögliche Quellspalte (Umsatz ...) Const lngZeZ = 15 ' Zeile mit Überschriften in Zieldatei intSpZ = 2 ' 1. Zielspalte ' Vorgaben Ende Set wks = ActiveSheet strFile = Dir(strVerz & "\*.xls") If strFile = "" Then MsgBox "Keine Dateien in '" & strVerz & "' gefunden!" Else While Len(strFile) > 0 Workbooks.Open Filename:=strVerz & "\" & strFile, UpdateLinks:=False intSp = intSpQ While Left(Cells(lngZeQ, intSp), 6) = "Umsatz" lngLast = Cells(lngZeQ, intSp).End(xlDown).Row Range(Cells(lngZeQ, intSp), Cells(lngLast, intSp)).Copy _ Destination:=wks.Cells(lngZeZ, intSpZ) intSpZ = intSpZ + 1 If intSpZ > Columns.Count Then MsgBox "Spalten der Zieldatei reichen nicht aus." Exit Sub End If intSp = intSp + 1 Wend While Not IsEmpty(Cells(lngZeQ, intSp)) If Cells(lngZeQ, intSp) = "Personalkosten" Then lngLast = Cells(lngZeQ, intSp).End(xlDown).Row Range(Cells(lngZeQ, intSp), Cells(lngLast, intSp)).Copy _ Destination:=wks.Cells(lngZeZ, intSpZ) intSpZ = intSpZ + 1 If intSpZ > Columns.Count Then MsgBox "Spalten der Zieldatei reichen nicht aus." Exit Sub End If End If intSp = intSp + 1 Wend ActiveWorkbook.Close False strFile = Dir Wend End If End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Rainer,
dass Mappen in c:\umsatz bereits geöffnet sein können, wurde bisher im Makro nicht berücksichtigt. Bisher wurden alle Quellmappen geschlossen - ohne Speicherung eventueller Änderungen.
Wenn eine Quellmappe bereits geöffnet ist, wird mit nachfolgendem Code kein weiterer Öffnen-Versuch unternommen, und die Mappe bleibt offen:


Option Explicit
Sub Kopie_aus_Mappen2()
Dim strFile As String, ergOpen As String
Dim intSpZ%, intSp%
Dim wks As Worksheet, ii%, lngLast&
'                                                                 Vorgaben
Const strVerz = "c:\umsatz"   ' Quellverzeichnis
'   Const strVerz = "f:\exc\w-w-w\tmp\rainer"   ' Quellverzeichnis
Const lngZeQ = 16       ' Zeile mit Überschriften in Quelldateien
Const intSpQ = 4        ' 1. mögliche Quellspalte (Umsatz ...)
Const lngZeZ = 15       ' Zeile mit Überschriften in Zieldatei
intSpZ = 2              ' 1. Zielspalte
'                                                                 Vorgaben Ende
Set wks = ActiveSheet
strFile = Dir(strVerz & "\*.xls")
If strFile = "" Then
MsgBox "Keine Dateien in '" & strVerz & "' gefunden!"
Else
While Len(strFile) > 0
ergOpen = myOpen(strVerz, strFile, False)    ' ## neu
If Left(ergOpen, 1) = "0" Then
MsgBox ergOpen
Exit Sub
End If                                       ' ## Ende neu
intSp = intSpQ
While Left(Cells(lngZeQ, intSp), 6) = "Umsatz"
lngLast = Cells(lngZeQ, intSp).End(xlDown).Row
Range(Cells(lngZeQ, intSp), Cells(lngLast, intSp)).Copy _
Destination:=wks.Cells(lngZeZ, intSpZ)
intSpZ = intSpZ + 1
If intSpZ > Columns.Count Then
MsgBox "Spalten der Zieldatei reichen nicht aus."
Exit Sub
End If
intSp = intSp + 1
Wend
While Not IsEmpty(Cells(lngZeQ, intSp))
If Cells(lngZeQ, intSp) = "Personalkosten" Then
lngLast = Cells(lngZeQ, intSp).End(xlDown).Row
Range(Cells(lngZeQ, intSp), Cells(lngLast, intSp)).Copy _
Destination:=wks.Cells(lngZeZ, intSpZ)
intSpZ = intSpZ + 1
If intSpZ > Columns.Count Then
MsgBox "Spalten der Zieldatei reichen nicht aus."
Exit Sub
End If
End If
intSp = intSp + 1
Wend
If Left(ergOpen, 1) < "2" Then ActiveWorkbook.Close False ' ## neu
ThisWorkbook.Activate
strFile = Dir
Wend
End If
End Sub
Function myOpen$(ByVal Pfad$, ByVal FName$, UpdLinks As Boolean)  ' ## neu
If Right(Pfad, 1) <> "\" Then Pfad = Pfad & "\"
On Error Resume Next
Windows(FName).Activate
If Err = 0 Then _
myOpen = "2 - war offen, wurde aktiviert": Exit Function
Err.Clear
Windows(Pfad & FName).Activate
If Err = 0 Then _
myOpen = "2 - war offen, wurde aktiviert": Exit Function
Err.Clear
If Dir(Pfad & FName) = "" Then _
myOpen = "0 - Datei nicht gefunden": Exit Function
Open Pfad & FName For Random Access Read Lock Read Write As #1
Close #1
If Err = 70 Then _
myOpen = "0 - Zugriff verweigert": Err.Clear: Exit Function
If Err <> 0 Then _
myOpen = "0 - Fehler beim Open": Err.Clear: Exit Function
Workbooks.Open Filename:=Pfad & FName, UpdateLinks:=UpdLinks
If Err = 0 Then
myOpen = "1 - wurde geöffnet": Exit Function
Else
myOpen = "0 - Fehler beim Öffnen": Err.Clear: Exit Function
End If
On Error GoTo 0
End Function

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread