hoomes
Goto Top

VBA Import unter Berücksichtigung von Wert X

Hallo Leute ich brauch eure Hilfe... ich hab einen Automatischen Import in VBA eingerichtet. Kurz zur Verständnis: Hier werden Standorte besucht und bewertet. Am Schluss sollen alle kumuliert reported werden. Ich muss diese nach Region importieren lassen. Ich würde gerne in der Import-Excel angeben welche Region er auswerten soll und dann anhand einer Matrix schauen welche Standorte in dieser Region sind. Könnt ihr mir helfen? Hier mein bisherig werk für den automatischen Import Ohne Berücksichtigung der Region:

Option Explicit

Dim objFileSystemObject As Object
Dim objDateien As Object
Dim objWeitereDateien As Object
Dim objDatei As Object
Dim lngFirstFreeRow As Long
Dim wksAuswertsheet As Worksheet

Sub Auswertung_start()
'Objektverweise zuweisen  
Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")  
Set objDateien = objFileSystemObject.getfolder(ThisWorkbook.Worksheets("Welcome").Range("A7").Value)  
Set wksAuswertsheet = ThisWorkbook.Sheets("Evaluation")  

Call Dateien_auswerten

'Zuweisung wieder aufheben  
Set objFileSystemObject = Nothing
Set objDateien = Nothing
Set wksAuswertsheet = Nothing

'Text aus Statusbar löschen  
Application.StatusBar = ""  
End Sub
'###########################################################################################  

Sub Dateien_auswerten()

Application.ScreenUpdating = False

For Each objDatei In objDateien.Files
If Right(objDatei.Name, 4) = ".xls" Or Right(objDatei.Name, 5) = ".xlsx" _  
Or Right(objDatei.Name, 5) = ".xlsm" Then  

'erste freie Zelle in der Zieldatei in Spalte A ermitteln  
lngFirstFreeRow = wksAuswertsheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

'Meldung in Statusbar anzeigen  
Application.StatusBar = "Datei """ & objDatei.Name & """ wird ausgel esen!"  
DoEvents

'Gefundene Datei unsichtbar öffnen  
GetObject (objDatei)
Windows(objDatei.Name).Visible = True

'"Audit for" wir aus den Dokumenten gelesen und in die erste freie Zelle in Spalte A übertragen  
wksAuswertsheet.Cells(lngFirstFreeRow, 1) = _
Workbooks(objDatei.Name).Sheets(2).Range("C1")  


'Geöffnete Datei wieder schließen ohne zu speichern  
Workbooks(objDatei.Name).Close SaveChanges:=False

End If
Next

'Nächstes Verzeichnis abfragen  
For Each objWeitereDateien In objDateien.subfolders
Set objDateien = objWeitereDateien
Call Dateien_auswerten
Next


End Sub

Vielen Dank schon mal für eure Ideen und Hilfe

Content-Key: 423147

Url: https://administrator.de/contentid/423147

Ausgedruckt am: 28.03.2024 um 16:03 Uhr

Mitglied: 139374
139374 02.04.2019 aktualisiert um 10:39:45 Uhr
Goto Top
Bei der Fülle an Informationen zum Aufbau etc., kein Wunder das da keiner Bock hat zu helfen.🙃🙃