VBA

Question

Hallo,

wer kennt sich mit VBA aus?
Ich möchte folgendes:
Ich habe von verschiedenen Mitarbeitern eine Agenda, die sie abarbeiten müssen und ich wöchentlich nachfrage.
Für jeden Mitarbeiter gibt es eine Exceldatei mit ca. 10 Punkten.
Ich bewerte diese Punkte mit Prioritäten.
Da ich die wichtigsten Ergebnisse an meinen Chef reporten muss möchte ich wissen, wie die Punkte der einzelnen Agenden mit der Priorität "H" für hoch automatisch in eine extra Datei kopiert werden, dass ich die wichtigsten Punkte eben automatisch in einer seperaten Excel-Liste habe. Geht das mit VBA und wenn ja wie.

Vielen Dank!

Ella

Answer 1

hi ella ^^

probier mal :-)

gruss nighty

Option Explicit

Sub DateienLesen()
Call EventsOff
Dim DateiName As String, ZellPos As Variant
Dim Lzeile As Long, Lspalte As Long
Rem Pfad der zu auslesenden dateien anpassen
DateiName = Dir("C:\Temp\" & "*.xls")
Lzeile = 1
Do While DateiName <> ""
Lzeile = Lzeile + 1
Rem bereich zur zeit I4 bis I13
For Each ZellPos In Array("I4", "I5", "I6", "I7", "I8", "I9", "I10", "I11", "I12", "I13")
Lspalte = Lspalte + 1
Rem Pfad der zu auslesenden dateien anpassen
Cells(Lzeile, Lspalte) = ExecuteExcel4Macro("'C:\Temp\" & "[" & DateiName & "]Tabelle1" & "'!" & Range("" & ZellPos).Address(, , xlR1C1))
Next ZellPos
Lspalte = 0
DateiName = Dir
Loop
Call EventsOn
End Sub

Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub

Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Answer 2

guten morgen,

das sieht höchst kompliziert aus. wie kann ich das nur wieder gut machen? ;)
Es müssen doch aber mehrere Dateien ausgelesen werden. Geht das auch? Jetzt lege ich doch nur einen Pfad.

grüße

Answer 3

hi ella ^^

ich mach das nochmal neu,hatte es falsch verstanden,

über die feiertage ^^

gruss nighty

Answer 4

hi ella ^^

probier mal :-)

gruss nighty

basiert auf excel 2000,daher habe ich fuer andere varianten keine anpassungsmöglichkeiten

nach einer ordnerauswahl weden alle darinliegenden exceldateien ausgelesen

überschrift zwingend durch den autofilter

Option Explicit

Sub DateienLesen()
Call EventsOff
Dim DateiName As String, DateiPfad As String
DateiPfad = OrdnerAuswahl
DateiName = Dir(DateiPfad & "*.xls")
Do While DateiName <> ""
If ThisWorkbook.Name <> DateiName Then
Workbooks.Open Filename:=DateiPfad & DateiName
Workbooks(DateiName).Worksheets(1).Range("A4:I" & Workbooks(DateiName).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row).Copy
Workbooks(1).Worksheets(1).Range("A" & Workbooks(1).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
Application.CutCopyMode = False
Workbooks(DateiName).Close SaveChanges:=False
End If
DateiName = Dir
Loop
Workbooks(1).Worksheets(1).Range("I1").AutoFilter Field:=9, Criteria1:="<>H", Operator:=xlAnd
Workbooks(1).Worksheets(1).Rows("2:" & Workbooks(1).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1).Delete Shift:=xlUp
Workbooks(1).Worksheets(1).Range("I1").AutoFilter
Worksheets(1).Range("A2").Activate
Call EventsOn
End Sub

Function OrdnerAuswahl() As String
On Error GoTo FehlerRoutine
Dim AppShell As Object
Dim BrowseDir As Variant
Set AppShell = CreateObject("Shell.Application")
Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17)
OrdnerAuswahl = BrowseDir.items().Item().Path & "\"
FehlerRoutine:
End Function

Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub

Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Answer 5

hi all ^^^

eine vereinfachte version ohne ereignisausschaltung wie auch ohne ordnerauswahl

gruss nighty

Option Explicit

Sub DateienLesen()
Dim DateiName As String, DateiPfad As String
DateiPfad = "C:\Temp\"
DateiName = Dir(DateiPfad & "*.xls")
Do While DateiName <> ""
If ThisWorkbook.Name <> DateiName Then
Workbooks.Open Filename:=DateiPfad & DateiName
Workbooks(DateiName).Worksheets(1).Range("A4:I" & Workbooks(DateiName).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row).Copy
Workbooks(1).Worksheets(1).Range("A" & Workbooks(1).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
Application.CutCopyMode = False
Workbooks(DateiName).Close SaveChanges:=False
End If
DateiName = Dir
Loop
Workbooks(1).Worksheets(1).Range("I1").AutoFilter Field:=9, Criteria1:="<>H", Operator:=xlAnd
Workbooks(1).Worksheets(1).Rows("2:" & Workbooks(1).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1).Delete Shift:=xlUp
Workbooks(1).Worksheets(1).Range("I1").AutoFilter
Worksheets(1).Range("A2").Activate
End Sub