AW: Das Ergebnis in...
04.07.2017 07:48:12
Saerdna
Hallo Case :-)
lieben Dank für Dein Unterstützung und ja, ich komme zwischenzeitlich wieder klar. :-) Habe die letzten Jahre mit VBA nichts mehr groß gemacht da meine Dateien funktioniert haben und somit rostet man halt dann doch etwas ein.
So, nach unzähligen Kaffee`s und Cigaretten habe ich mir nun eine Lösung gebastelt, die zumindest mal funktioniert. Habe Deinen ursprünglichen Code soweit angepasst, dass ich über ein For alle Zeilen in den vorgegebenen Spalten auslesen und somit in "meine" Datei importieren kann. Anbei mal der Code.
Option Explicit
' Variablendeklaration
Const strSheetQ As String = "Kunden" ' Der Tabellenblattname in der(n) auszulesenden Dateie(n)
Const strSheetZ As String = "Import" ' Der Tabellenblattname in DIESER Datei (die mit dem Code)
Dim ende As String
Dim antwort As String
' Module : Modul1
' Procedure : Files_Read
' Author : Case (Ralf Stolzenburg)
' Date : 29.10.2013
' Purpose : Geschlossene Dateien - mehrere Zellen auslesen...
Public Sub Files_Read()
antwort = MsgBox("Daten aus der(n) Dateie(n) importieren?", vbYesNo + vbQuestion, "Hinweis") ' _
Meldung anzeigen und Rückgabewert aus MsgBox speichern
If antwort = vbYes Then ' Wenn nicht abgebrochen, dann weiter mit nachfolgendem Code
' Variablendeklaration
Dim blnUpdate As Boolean
Dim intCalc As Integer
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
Dim lngCalc As Long
On Error GoTo Fin ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
MsgBox "Das importieren der Informationen kann" & vbCr & "je nach Anzahl an einzulesenden _
Dateien," & vbCr & " länger dauern." & vbCr & vbCr & "Weiter mit OK", 48, "Information"
' Die Excelapplikation wird ruhig gestellt - Bei z.B. Abbruch UNBEDINGT wieder einschalten!
With Application
.ScreenUpdating = False
blnUpdate = .AskToUpdateLinks
.AskToUpdateLinks = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
' Der Objektvariablen objFSO das "FilesystemObject" zuweisen
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Datei im gleichen Ordner wie Auswertungsdateien
strDir = ThisWorkbook.Path
'strDir = "C:\Temp\Los\" ' Fester Pfad
Set objDir = objFSO.GetFolder(strDir)
' Der Code bezieht sich auf ein bestimmtes Objekt
' Hier strSheetZ
' Alles was sich auf dieses "With" bezieht MUSS mit einem Punkt beginnen
With ThisWorkbook.Worksheets(strSheetZ)
' Inhalt von Tabelle "strSheetZ" wird ab Zeile 4 gelöscht
.Rows("4:" & .Rows.Count).ClearContents
' Mit Unterordner
'dirInfo objDir, "*.xls*", True ' Mit Unterordner
dirInfo objDir, "*.xlsm*" ' Ohne Unterordner
' Formeln entfernen - Werte bleiben erhalten
.UsedRange.Value = .UsedRange.Value
End With
Fin:
'Schlusscode
ThisWorkbook.Sheets("Import").Range("D2").Value = Date
Call LeerzeilenLoeschenundSortieren
Worksheets("Ergebnis").Select
Call Daten_aus_Import_einlesen
' Setze die Objektvariablen auf Nothing
Set objDir = Nothing
Set objFSO = Nothing
' Die Excelapplikation wieder aufwecken
With Application
.ScreenUpdating = True
.AskToUpdateLinks = blnUpdate
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
If Err.Number 0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
MsgBox "Alle vorhandenen Daten aus der(n) Dateie(n) importiert.", 64, "Information"
End If
End Sub
' Module : Modul1
' Procedure : dirInfo
' Author : Case (Ralf Stolzenburg)
' Date : 29.10.2013
' Purpose : Geschlossene Dateien - mehrere Zellen auslesen...
' Rekursive Sub mit Array - Optional mit Unterordner
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
' Variablendeklaration
Dim strFormula As String
Dim lngLastRow As Long
Dim arrCell As Variant
Dim intTMP As Integer
Dim varTMP As Variant
Dim Bereich As Integer ' Für die Anzahl der Zeilen die ausgelesenen werden sollen. Entspricht _
der Anzahl Kunden die aktuell in der Kundenliste angelegt werden können
Dim BZaehler As Integer ' Für die Schleife zum verschieben der einzufügenden Zellen auf die nä _
chste Zeile
Bereich = 100 ' Anzahl der Zeilen (entspricht der Anzahl Kunden) die ausgelesenen werden _
sollen
' Alle Dateien im vorgegebenen Ordner
For Each varTMP In objCurrentDir.Files
' Dateiname entspricht den Vorgaben und ist nicht DIESE Datei
If varTMP.Name Like strName And varTMP.Name _
ThisWorkbook.Name And Left(varTMP.Name, 1) "~" Then ' und ist KEINE temporäre _
Datei
' Der Code bezieht sich auf ein bestimmtes Objekt, hier strSheetZ
' Alles was sich auf dieses "With" bezieht MUSS mit einem Punkt beginnen
With ThisWorkbook.Worksheets(strSheetZ)
' Letzte Zeile bezogen auf Spalte A plus 1
lngLastRow = IIf(Len(.Cells(.Rows.Count, 1)), _
.Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
For BZaehler = 4 To Bereich ' Zeile ab der ausgelesen wird
arrCell = Array("C" & BZaehler, "H" & BZaehler, "A" & BZaehler)
' Schleife über alle Zellen des Arrays
For intTMP = LBound(arrCell) To UBound(arrCell)
' Hier kann noch der Dateiname mit komplettem Pfad in die nächste freie _
Spalte geschrieben werden
'.Cells(lngLastRow, UBound(arrCell) + 2).Value = varTMP.Path
' Hier kann noch der Dateiname incl. Erweiterung in die nächste freie _
Spalte geschrieben werden
.Cells(lngLastRow, UBound(arrCell) + 2).Value = varTMP.Name
' Werte über Formel holen, Tabellenblatt über "Const..." oben definiert, _
Zelle über Array. Formel in Spalte A folgende...
.Cells(lngLastRow, intTMP + 1).Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & Mid(varTMP.Path, InStrRev( _
varTMP.Path, "\") + 1) & "]" & strSheetQ & "'!" & arrCell(intTMP)
Next intTMP
lngLastRow = lngLastRow + 1
Next BZaehler
End With
End If
Next varTMP
' Wenn die Variable blnTMP "True" ist (in der Sub "Files_Read_1" vorgegeben dann durchsuche _
auch alle Unterordner
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, blnTMP
Next varTMP
End If
End Sub
Sicherlich würde eine ausgewiesener Excel bzw. VBA Experte den von mir angepassten Code anders/besser schreiben, aber für meine VBA-Kenntnisse habe ich zumindest mein Ergebnis damit erreicht. :-)
Nach dem hier gezeigten Code folgen noch einige weitere Verarbeitungsschritte (Codes) und am Ende habe ich eine, für mein dafürhalten, wunderbare Zusammenfassung. :-)
Viele Grüße
Andreas