Live-Forum - Die aktuellen Beiträge
Datum
Titel
26.04.2024 21:51:33
Idee für Grafik
26.04.2024 21:29:07
PQ zufällige Reihenfolge
26.04.2024 17:18:47
Große Datenmenge in komplexes Diagramm verpacken
26.04.2024 16:22:47
Aktualisierung Verknüpfung bei geschlossener Quelldatei
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1764to1768
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
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1764to1768
1764to1768
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

VBA

VBA
15.06.2020 12:24:20
Karl
Hi! Ich habe ein Projekt und komme einfach nicht weiter!
Mit dem unten angeführten Code lese ich aus mehreren Excel Dateien Werte aus.
Beim Öffnen der Datei werden die Werte immer aus dem Active sheet ausgelesen. Wenn jetzt ein falscher sheet in der Tabelle aktiv ist werden falsche Werte ausgelesen.
Wie kann ich ein bestimmtes Tabellenblatt ansprechen? in meinem Fall Tabelle1 (Übersicht)
Ich komm einfach nicht drauf.
Danke für eure Hilfe
Charly
Sub GetData()
Set oMe = ThisWorkbook.ActiveSheet 'ZielDatei/-Tabelle (= die aktuelle Tabelle der aktuellen  _
Datei)
Const sDateiPfad As String = "C:\DK Test\" 'Pfad für zu durchsuchende Excel-Dateien; mit  _
Backslash am Ende
sZelle1 = "B5" 'NOx 1. Temp.
sZelle2 = "B4" 'NOx 1. K-Wert.
sZelle3 = "C5" 'NOx 2. Temp.
sZelle4 = "C4" 'Nox 2. K-Wert.
sZelle5 = "D5" 'SOx 1. Temp.
sZelle6 = "D4" 'SOx 1. ETA
sZelle7 = "E5" 'SOx 2. Temp.
sZelle8 = "E4" 'SOx 2. ETA
sZelle9 = "F4" 'Porenvolumen.
sZelle10 = "G4" 'Abrieb
sZelle11 = "H4" 'BET
sZelle12 = "I4" 'Druckprüfung long.
sZelle13 = "J4" 'Druckprüfung trans.
sZelle14 = "K4" 'Vanadium ist
sZelle15 = "G2" 'Vanadium soll
sZelle16 = "A1" 'Auftragsnummer+Name
iZeile = 4 'ab Zeile 4 in Zieltabelle eintragen
iSpalte = 1 'ab Spalte A in Zieltabelle eintragen
Set oFS = CreateObject("Scripting.FileSystemObject")
For Each oDatei In oFS.GetFolder(sDateiPfad).Files
sWbName = oDatei.Name
If Left(LCase(oFS.GetExtensionName(sWbName)), 3) = "xls" Then
Workbooks.Open (sDateiPfad & sWbName)
oMe.Cells(iZeile, iSpalte).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle1).Value
oMe.Cells(iZeile, iSpalte + 1).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle2). _
Value
oMe.Cells(iZeile, iSpalte + 2).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle3). _
Value
oMe.Cells(iZeile, iSpalte + 3).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle4). _
Value
oMe.Cells(iZeile, iSpalte + 4).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle5). _
Value
oMe.Cells(iZeile, iSpalte + 5).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle6). _
Value
oMe.Cells(iZeile, iSpalte + 6).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle7). _
Value
oMe.Cells(iZeile, iSpalte + 7).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle8). _
Value
oMe.Cells(iZeile, iSpalte + 8).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle9). _
Value
oMe.Cells(iZeile, iSpalte + 9).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle10). _
Value
oMe.Cells(iZeile, iSpalte + 10).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle11). _
Value
oMe.Cells(iZeile, iSpalte + 11).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle12). _
Value
oMe.Cells(iZeile, iSpalte + 12).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle13). _
Value
oMe.Cells(iZeile, iSpalte + 13).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle14). _
Value
oMe.Cells(iZeile, iSpalte + 14).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle15). _
Value
oMe.Cells(iZeile, iSpalte + 15).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle16). _
Value
Workbooks(sWbName).Saved = True
Workbooks(sWbName).Close
iZeile = iZeile + 1
End If
Next
End Sub

11
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA
15.06.2020 12:29:17
Hajo_Zi
für ActiveSheet sheet("Tabelle125")

AW: VBA
15.06.2020 12:47:22
Karl
Hi!
Ich stehe gerade komplett auf der Leitung!
Könntest du die Änderung bitte bitte in meinem Code vornehmen.
Damit ich es versthe
AW: VBA
15.06.2020 12:54:46
Hajo_Zi
benutze Strg+H
Gruß Hajo
AW: VBA
15.06.2020 13:20:36
Gerd
Moin 
For Each oDatei In oFS.GetFolder(sDateiPfad).Files
sWbName = oDatei.Name
If Left(LCase(oFS.GetExtensionName(sWbName)), 3) = "xls" Then
With Workbooks(sWbName).Worksheets("Übersicht")
oMe.Cells(iZeile, ispalte).Resize(1, 16) = _
Array(.Range(sZelle1).Value, _
.Range(sZelle2).Value, _
.Range(sZelle3).Value, _
.Range(sZelle41).Value, _
.Range(sZelle5).Value, _
.Range(sZelle6).Value, _
.Range(sZelle7).Value, _
.Range(sZelle8).Value, _
.Range(sZelle9).Value, _
.Range(sZelle10).Value, _
.Range(sZelle11).Value, _
.Range(sZelle12).Value, _
.Range(sZelle13).Value, _
.Range(sZelle14).Value, _
.Range(sZelle15).Value, _
.Range(sZelle16).Value)
End With
Workbooks(sWbName)..Close SaveChanges:=True
End If
iZeile = iZeile + 1
End If
Next

Gruß Gerd
Anzeige
AW: VBA
15.06.2020 13:12:26
volti
Hallo Karl,
wenn ich Dich richtig verstanden habe, könntest Du es so wie im nachfolgend Ausschnitt gezeigt machen.
Das Quellblatt aus der Quelldatei (immer "Tabelle1") wird einer Objektvariablen zugewiesen. Hierdurch kann der Code kürzer ausfallen.
Für den Zielbereich habe ich mal die Offset-Variante eingeführt.
Probiere es aus, ich konnte es nicht testen...
      If Left(LCase(oFS.GetExtensionName(sWbName)), 3) = "xls" Then
  
  
          Workbooks.Open (sDateiPfad & sWbName)
          Set WSh = Workbooks(sWbName).Sheets("Tabelle1") 'oder übersicht, wenn das Blatt so heißt
          
          With oMe.Cells(iZeile, iSpalte)
           .Offset(0, 0).Value = WSh.Range(sZelle1).Value
           .Offset(0, 1).Value = WSh.Range(sZelle2).Value
           .Offset(0, 2).Value = WSh.Range(sZelle3).Value
           .Offset(0, 3).Value = WSh.Range(sZelle4).Value
           .Offset(0, 4).Value = WSh.Range(sZelle5).Value
           .Offset(0, 5).Value = WSh.Range(sZelle6).Value
           .Offset(0, 6).Value = WSh.Range(sZelle7).Value
           .Offset(0, 7).Value = WSh.Range(sZelle8).Value
           .Offset(0, 8).Value = WSh.Range(sZelle9).Value
           .Offset(0, 9).Value = WSh.Range(sZelle10).Value
           .Offset(0, 10).Value = WSh.Range(sZelle11).Value
           .Offset(0, 11).Value = WSh.Range(sZelle12).Value
           .Offset(0, 12).Value = WSh.Range(sZelle13).Value
           .Offset(0, 13).Value = WSh.Range(sZelle14).Value
           .Offset(0, 14).Value = WSh.Range(sZelle15).Value
           .Offset(0, 15).Value = WSh.Range(sZelle16).Value
          End With
          
          Workbooks(sWbName).Saved = True
  
  
          Workbooks(sWbName).Close
  
  
          iZeile = iZeile + 1
  
  
      End If

Viele Grüße aus Freigericht
Karl-Heinz

Anzeige
AW: VBA
15.06.2020 13:29:54
Karl
Hi volti!
Vielen vielen Dank! Genau danach habe ich gesucht.
Eine Frage hätte ich noch: Kann man irgendwie verhindern, dass jedesmal alle Dateien durchsucht werden?
Das heißt, dass bereits eingelesene Dateien gar nicht mehr geöffnet werden?
Danke
Charly
AW: VBA
15.06.2020 14:00:08
volti
Hallo Karl,
man kann (fast) alles machen mit VBA.
Dieser Code liest alle Dateien im Ordner.
For Each oDatei In oFS.GetFolder(sDateiPfad).Files
Um schon gelesene Dateien nicht noch mal zu öffnen und einzulesen, musst Du
  • irgendeinen Merker setzen, z.B. Dateinamen in eine Liste schreiben und auswerten)
  • oder die bereits eingelesene Datei löschen oder verschieben
  • oder das z.B. Dateierstellungsdatum auslesen und mit dem Einlesedatum abgleichen
  • oder ggf. weitere Möglichkeiten verwenden

viele Grüße
Karl-Heinz
Anzeige
AW: VBA
15.06.2020 14:14:34
Karl
Dankeschön!
Ich nehme den leichteren Weg und verschiebe die bereits ausgelesenen Dateien.
LG
Charly
AW: VBA
16.06.2020 05:56:20
Karl
Hi Karl-Heinz
Ich habe mich dazu entschieden die bereits eingelesenen Dateien zu verschieben.
Wenn ich jetzt neue Dateien in den Ordner lege, und meinen Code ausführe, werden meine vorhanden Werte überschrieben! Wie kann ich diese Werte fixieren, dass das nicht passiert?
Danke für deine Unterstützung
Charly
Set oMe = ThisWorkbook.ActiveSheet 'ZielDatei/-Tabelle (= die aktuelle Tabelle der aktuellen Datei)
Const sDateiPfad As String = "C:\DK Test\" 'Pfad für zu durchsuchende Excel-Dateien; mit Backslash am Ende
sZelle1 = "B5" 'NOx 1. Temp.
sZelle2 = "B4" 'NOx 1. K-Wert.
sZelle3 = "C5" 'NOx 2. Temp.
sZelle4 = "C4" 'Nox 2. K-Wert.
sZelle5 = "D5" 'SOx 1. Temp.
sZelle6 = "D4" 'SOx 1. ETA
sZelle7 = "E5" 'SOx 2. Temp.
sZelle8 = "E4" 'SOx 2. ETA
sZelle9 = "F4" 'Porenvolumen.
sZelle10 = "G4" 'Abrieb
sZelle11 = "H4" 'BET
sZelle12 = "I4" 'Druckprüfung long.
sZelle13 = "J4" 'Druckprüfung trans.
sZelle14 = "K4" 'Vanadium ist
sZelle15 = "G2" 'Vanadium soll
sZelle16 = "A1" 'Auftragsnummer+Name
iZeile = 4 'ab Zeile 4 in Zieltabelle eintragen
iSpalte = 1 'ab Spalte A in Zieltabelle eintragen
Set oFS = CreateObject("Scripting.FileSystemObject")
For Each oDatei In oFS.GetFolder(sDateiPfad).Files
sWbName = oDatei.Name
If Left(LCase(oFS.GetExtensionName(sWbName)), 3) = "xls" Then
Workbooks.Open (sDateiPfad & sWbName)
Set WSh = Workbooks(sWbName).Sheets("Übersicht")
With oMe.Cells(iZeile, iSpalte)
.Offset(0, 0).Value = WSh.Range(sZelle1).Value
.Offset(0, 1).Value = WSh.Range(sZelle2).Value
.Offset(0, 2).Value = WSh.Range(sZelle3).Value
.Offset(0, 3).Value = WSh.Range(sZelle4).Value
.Offset(0, 4).Value = WSh.Range(sZelle5).Value
.Offset(0, 5).Value = WSh.Range(sZelle6).Value
.Offset(0, 6).Value = WSh.Range(sZelle7).Value
.Offset(0, 7).Value = WSh.Range(sZelle8).Value
.Offset(0, 8).Value = WSh.Range(sZelle9).Value
.Offset(0, 9).Value = WSh.Range(sZelle10).Value
.Offset(0, 10).Value = WSh.Range(sZelle11).Value
.Offset(0, 11).Value = WSh.Range(sZelle12).Value
.Offset(0, 12).Value = WSh.Range(sZelle13).Value
.Offset(0, 13).Value = WSh.Range(sZelle14).Value
.Offset(0, 14).Value = WSh.Range(sZelle15).Value
.Offset(0, 15).Value = WSh.Range(sZelle16).Value
End With
Workbooks(sWbName).Saved = True
Workbooks(sWbName).Close
iZeile = iZeile + 1
End If
Next
End Sub
Anzeige
AW: VBA
16.06.2020 09:01:52
volti
Hallo Charly,
teste mal nachfolgendes Makro, ob es das macht, was Du möchtest. Ich konnte es nicht testen.
Habe mir erlaubt, es etwas zu vereinfachen., und empfehle Dir auch, immer die Variablen zu dimensionieren. Die beiden Option-Schalter bitte mit übernehmen...
Option Explicit
Option Compare Text
Sub GetData()
 Dim oFS As Object, oDatei As Object
 Dim WSh As Worksheet, oMe As Worksheet
 Dim sWbName As String
 Dim iZeile As Long, iSpalte As Integer
 Const sDateiPfad As String = "C:\DK Test\" 'Pfad für zu durchsuchende Excel-Dateien; mit Backslash am Ende
 Const sNeuerPfad As String = "C:\Users\voltm\Desktop\" 'anpassen!!!!!!!!!!
 iSpalte = 1 'ab Spalte A in Zieltabelle eintragen
 
 On Error GoTo Fehler
 
 Set oMe = ThisWorkbook.ActiveSheet 'ZielDatei/-Tabelle (= die aktuelle Tabelle der aktuellen Datei)
        
 Set oFS = CreateObject("Scripting.FileSystemObject")
        
 For Each oDatei In oFS.GetFolder(sDateiPfad).Files      'Alle Dateien durchgehen
   sWbName = oDatei.Name
        
   If oFS.GetExtensionName(sWbName) Like "xls*" Then     'Prüfen ob Excel
    
     Workbooks.Open (sDateiPfad & sWbName)               'Datei öffnen
     Set WSh = Workbooks(sWbName).Sheets(2) '"Tabelle1")     'Blatt referenzieren
    
     iZeile = oMe.Cells(Rows.Count, 1).End(xlUp).Row + 1 'Zeile ermitteln
    
     With oMe.Cells(iZeile, iSpalte)
        .Offset(0, 0).value = WSh.Range("B5").value      'NOx 1. Temp.
        .Offset(0, 1).value = WSh.Range("B4").value      'NOx 1. K-Wert.
        .Offset(0, 2).value = WSh.Range("C5").value      'NOx 2. Temp.
        .Offset(0, 3).value = WSh.Range("C4").value      'Nox 2. K-Wert.
        .Offset(0, 4).value = WSh.Range("D5").value      'SOx 1. Temp.
        .Offset(0, 5).value = WSh.Range("D4").value      'SOx 1. ETA
        .Offset(0, 6).value = WSh.Range("E5").value      'SOx 2. Temp.
        .Offset(0, 7).value = WSh.Range("E4").value      'SOx 2. ETA
        .Offset(0, 8).value = WSh.Range("F4").value      'Porenvolumen.
        .Offset(0, 9).value = WSh.Range("G4").value      'Abrieb
        .Offset(0, 10).value = WSh.Range("H4").value     'BET
        .Offset(0, 11).value = WSh.Range("I4").value     'Druckprüfung long.
        .Offset(0, 12).value = WSh.Range("J4").value     'Druckprüfung trans.
        .Offset(0, 13).value = WSh.Range("K4").value     'Vanadium ist
        .Offset(0, 14).value = WSh.Range("G2").value     'Vanadium soll
        .Offset(0, 15).value = WSh.Range("A1").value     'Auftragsnummer+Name
     End With
          
     Workbooks(sWbName).Saved = True                     'Datei gespeichert
     Workbooks(sWbName).Close                            'Datei schließen
        
     Name sDateiPfad & sWbName As sNeuerPfad & sWbName   'Datei verschieben
        
    End If
        
 Next
 
 MsgBox "Bin fertig!", vbInformation, "Dateien einlesen"
 Exit Sub
 
Fehler:
 MsgBox "Es ist der Fehler " & Error & " aufgetreten", vbCritical, "Dateien einlesen"
        
End Sub

Viele Grüße aus Freigericht
Karl-Heinz

Anzeige
AW: VBA
16.06.2020 09:47:35
Karl
Wow!!!
Funktioniert tadellos!
Du bist der Hammer. Vielen Dank!

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige