Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1432to1436
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Codeoptimierung Datei auslesen

Codeoptimierung Datei auslesen
08.07.2015 10:02:37
braun
Guten Morgen,
ich habe eben folgenden Makro Code bekommen. Dieses Makro soll Dateien auslesen. Ich habe diesen Code selber nicht geschrieben, er soll aber optimiert werden, da dieses Makro bei einem großen Datenatz sehr lange durchläuft. Kann mir irgendjemand helfen?
Vielen Dank im Voraus!
Sub Makro1()
'Alle xlsx-Dokumente in ein Array einlesen
Dim lngAnzahl As Long
Dim strDatei As String
Dim strDateien() As String
strDatei = Dir(ThisWorkbook.Path & "\*.xls")
Do While Len(strDatei)
If strDatei  ThisWorkbook.Name Then
lngAnzahl = lngAnzahl + 1
ReDim Preserve strDateien(1 To lngAnzahl)
strDateien(lngAnzahl) = strDatei
End If
strDatei = Dir
Loop
Dim datei_anzahl As Integer
'Anzahl Dateien in Array zählen
datei_anzahl = UBound(strDateien, 1) - LBound(strDateien, 1) + 1
'Datei auslesen
For i = 1 To datei_anzahl
objectname = ThisWorkbook.Path & "\" & strDateien(i)
Dim objexcel As New Excel.Application
Dim objsheet As Object
objexcel.Workbooks.Open objectname
Set objsheet = objexcel.Sheets(1)
s = i + 4
Cells(1, s) = strDateien(i)
Dim loletzte As Long
loletzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows. _
Count)
For j = 2 To loletzte
Dim loLetzte2 As Long
loLetzte2 = IIf(IsEmpty(objsheet.Cells(Rows.Count, 1)), objsheet.Cells(Rows.Count, 1).  _
_
End(xlUp).Row, objsheet.Rows.Count)
For k = 2 To loLetzte2
If Cells(j, 1) = objsheet.Cells(k, 1) Then
Cells(j, s) = objsheet.Cells(k, 3)
Else
End If
Next
Next
objexcel.EnableEvents = False
objexcel.DisplayAlerts = False
'objexcel.ActiveWorkbook.SaveAs objectname
objexcel.ActiveWorkbook.Close savechanges:=False
objexcel.Quit
Set objexcel = Nothing
Set objsheet = Nothing
Next
End Sub

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Codeoptimierung Datei auslesen
08.07.2015 11:49:48
Rudi
Hallo,
teste mal:
Sub Makro1()
'Alle xlsx-Dokumente in ein Array einlesen
Dim lngAnzahl As Long
Dim strDatei As String
Dim colDateien As New Collection
Dim loletzte As Long
Dim loLetzte2 As Long
Dim objWkb As Workbook, objSheet As Worksheet
Dim wsAkt As Worksheet
Dim i As Long, j As Long, k As Long, s As Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
On Error GoTo ERREXIT
Set wsAkt = ActiveSheet
strDatei = Dir(ThisWorkbook.Path & "\*.xlsx")
Do While Len(strDatei)
If strDatei  ThisWorkbook.Name Then
lngAnzahl = lngAnzahl + 1
colDateien.Add strDatei, CStr(lngAnzahl)
End If
strDatei = Dir
Loop
'Datei auslesen
For i = 1 To colDateien.Count
strDatei = colDateien(CStr(i))
Set objWkb = Workbooks.Open(ThisWorkbook.Path & "\" & strDatei)
Set objSheet = objWkb.Sheets(1)
s = i + 4
With wsAkt
.Cells(1, s) = strDatei
loletzte = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
.Cells(.Rows.Count, 1).End(xlUp).Row, _
.Rows.Count)
End With
For j = 2 To loletzte
With objSheet
loLetzte2 = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
.Cells(.Rows.Count, 1).End(xlUp).Row, _
.Rows.Count)
For k = 2 To loLetzte2
If wsAkt.Cells(j, 1) = .Cells(k, 1) Then
wsAkt.Cells(j, s) = .Cells(k, 3)
End If
Next k
End With
Next j
objWkb.Close False
Next
ERREXIT:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub

Gruß
Rudi

Anzeige
AW: Codeoptimierung Datei auslesen
08.07.2015 13:27:44
braun
Hallo,
leider passiert bei diesem Code nichts, er übernimmt nicht die Daten aus den anderen Files.
Viele Grüße

AW: Codeoptimierung Datei auslesen
09.07.2015 12:16:54
braun
Hat noch jemand eine Idee? LG :)

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige