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

Daten übertragen @Josef Ehrensberger

Daten übertragen @Josef Ehrensberger
werner-schmidt
Hallo
wer kann mir helfen? Ich habe aus dem Forum einen Code von Josef Ehrensberger gefunden
(Orinal weiter unten) und auf meine Bedürfnisse umgeschrieben.
Der Code soll mir aus den gleichmäßig aufgebauten Dateien (ca. 30) 10 Werte herauskopiern
Text und auch Zahl.
Der Code funktioniert wenn nur 3 Werte herauskopiert werden. Bei 4 Werten bricht das Makro
nach 20 Schleifen mit der Meldung "400" ab.
Was läuft falsch?
Bin für jede Info dankbar.
Tschüs Werner
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub Daten_Lesen()
Dim strPath As String, strFile As String, strTabName As String
Dim lngR As Long, Monate As Long, Jahr As Long
Monate = Range("A1") 'zelle mit den Monaten (z.B 8)
Jahr = Range("A2")   'zelle mit dem Jahr  (z.B 2009)
strPath = "C:\Test\Protokolle\Tagesprotokolle\" & Jahr & "\" & Monate & "\"   'Verzeichnis  _
anpassen!
strTabName = "Tabelle1" 'Name der Tabellenblätter anpassen!
strFile = Dir(strPath & "*.xls")
lngR = 4 'Für Zeile 4
With ThisWorkbook.Sheets("Tabelle1") 'Name der Ausgabetabelle anpassen!
.Range("A5:L" & Rows.Count).ClearContents  'Spalten löschen
Do Until strFile = ""
lngR = lngR + 1
.Cells(lngR, 1) = strFile
.Cells(lngR, 2).Formula = "=('" & strPath & "[" & strFile & "]" & _
strTabName & "'!$b$32)"    '1.Text übernommen
.Cells(lngR, 2) = .Cells(lngR, 2).Value
.Cells(lngR, 3).Formula = "=('" & strPath & "[" & strFile & "]" & _
strTabName & "'!$b$33)"    '2.Text übernommen
.Cells(lngR, 3) = .Cells(lngR, 3).Value
.Cells(lngR, 4).Formula = "=('" & strPath & "[" & strFile & "]" & _
strTabName & "'!$b$34)"    '3.Text übernommen
.Cells(lngR, 4) = .Cells(lngR, 4).Value
strFile = Dir
.Cells(lngR, 5).Formula = "=('" & strPath & "[" & strFile & "]" & _  '

########################
--------ORGINAL--------
Hallo Stefan,
probier mal diesen Code. (Kommentare beachten!)
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub Daten_Lesen()
Dim strPath As String, strFile As String, strTabName As String
Dim lngR As Long
strPath = "F:\Temp\km\" 'Verzeichnis anpassen!
strTabName = "Tabelle1" 'Name der Tabellenblätter anpassen!
strFile = Dir(strPath & "*.xls")
lngR = 1
With ThisWorkbook.Sheets("Tabelle1") 'Name der Ausgabetabelle anpassen!
.Range("A2:B" & Rows.Count).ClearContents
Do Until strFile = ""
lngR = lngR + 1
.Cells(lngR, 1) = strFile
.Cells(lngR, 2).Formula = "=SUM('" & strPath & "[" & strFile & "]" & _
strTabName & "'!$K$7:$K$17)"
.Cells(lngR, 2) = .Cells(lngR, 2).Value
strFile = Dir
Loop
End With
End Sub

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

Betreff
Benutzer
Anzeige
AW: Daten übertragen @Josef Ehrensberger
24.09.2009 22:15:15
Josef
Hallo Werner,
ausser das du zweimal "strFile = Dir" im Code stehen hast, kann ich keinen Fehler erkennen.
Probier mal diesen Code.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Daten_Lesen()
  Dim strPath As String, strFile As String, strTabName As String
  Dim lngR As Long, Monate As Long, Jahr As Long
  '########
  Monate = Range("A1") 'zelle mit den Monaten (z.B 8)
  Jahr = Range("A2") 'zelle mit dem Jahr (z.B 2009)
  '########
  
  strPath = "C:\Test\Protokolle\Tagesprotokolle\" & Jahr & "\" & Monate & "\" 'Verzeichnis _
    anpassen!

  strTabName = "Tabelle1" 'Name der Tabellenblätter anpassen!
  
  strFile = Dir(strPath & "*.xls")
  
  lngR = 4 'Für Zeile 4
  
  With ThisWorkbook.Sheets("Tabelle1") 'Name der Ausgabetabelle anpassen!
    
    .Range("A5:L" & Rows.Count).ClearContents 'Spalten löschen
    
    Do Until strFile = ""
      lngR = lngR + 1
      .Cells(lngR, 1) = strFile
      .Cells(lngR, 2) = GetValue(strPath, strFile, strTabName, "B32")
      .Cells(lngR, 3) = GetValue(strPath, strFile, strTabName, "B33")
      .Cells(lngR, 4) = GetValue(strPath, strFile, strTabName, "B34")
      .Cells(lngR, 5) = GetValue(strPath, strFile, strTabName, "I7")
      strFile = Dir
    Loop
    
  End With
  
End Sub


Private Function GetValue(path As String, file As String, _
    sheet As String, ref As String)

  ' Retrieves a value from a closed workbook
  Dim arg As String
  ' Make sure the file exists
  If Right(path, 1) <> "\" Then path = path & "\"
  
  If Dir(path & file) = "" Then
    GetValue = "File Not Found"
    Exit Function
  End If
  
  ' Create the argument
  arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
    Range(ref).Range("A1").Address(, , xlR1C1)
  
  ' Execute an XLM macro
  GetValue = ExecuteExcel4Macro(arg)
End Function

Gruß Sepp

Anzeige
AW: Daten übertragen @Josef Ehrensberger
25.09.2009 18:44:58
werner-schmidt
Hallo Josef
danke das du noch auf den Code geachtest hast.
es war das zweimal "strFile = Dir" was zum Fehler geführt hat. Klappt jetzt prima
habe noch aus deinen anderen Hilfen nachfolgenden Code eingesetzt und läüft schnell.
Dein neuer Code sieht wesentlich übersichtlicher aus, holt mir aber nur aus einer Datei( von 30)
in dem Ordner die Werte. Hast du noch eine Idee?
Vielen Dank erstmal für deine Mühe
Werner
On Error GoTo ErrExit
GMS
.......
ErrExit:
GMS True
Set rng = Nothing
Set rngDelete = Nothing
------------------------------------------
Public Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus 'Bildschirmaktualisierung ein/aus
.EnableEvents = Modus 'Ereignisprozeduren ein/aus
.DisplayAlerts = Modus 'Meldungen ein/aus
.EnableCancelKey = IIf(Modus, 1, 0) 'Unterbrechen mit ESC oder STRG+Unterbr. ein/aus
If Not Modus Then lngCalc = .Calculation 'Aktuellen Berechnungsmodus merken
If Modus And lngCalc = 0 Then lngCalc = -4105
'-4105 ist der Wert der vbKonstanten xlCalculationAutomatic
'-4135 ist der Wert von xlCalculationManual
.Calculation = IIf(Modus, lngCalc, -4135) 'Automatische Berechnung je nach Modus ein/aus
.Cursor = IIf(Modus, -4143, 2) 'Cursor ändern
End With
Anzeige
AW: Daten übertragen @Josef Ehrensberger
28.09.2009 21:37:27
Josef
Hallo Werner,
mein Fehler, man kann natürlich DIR() nur einmal verwenden. So geht's.
Sub Daten_Lesen()
  Dim strPath As String, strFile As String, strTabName As String, strRef As String
  Dim lngR As Long, Monate As Long, Jahr As Long
  '########
  Monate = Range("A1") 'zelle mit den Monaten (z.B 8)
  Jahr = Range("A2") 'zelle mit dem Jahr (z.B 2009)
  '########
  
  strPath = "C:\Test\Protokolle\Tagesprotokolle\" & Jahr & "\" & Monate & "\" 'Verzeichnis _
    anpassen!

  strTabName = "Tabelle1" 'Name der Tabellenblätter anpassen!
  
  strFile = Dir(strPath & "*.xls")
  
  lngR = 4 'Für Zeile 4
  
  With ThisWorkbook.Sheets("Tabelle1") 'Name der Ausgabetabelle anpassen!
    
    .Range("A5:L" & Rows.Count).ClearContents 'Spalten löschen
    
    Do Until strFile = ""
      lngR = lngR + 1
      .Cells(lngR, 1) = strFile
      strRef = "'" & strPath & "[" & strFile & "]" & strTabName & "'!"
      .Cells(lngR, 2) = ExecuteExcel4Macro(strRef & Range("B32").Range("A1").Address(, , xlR1C1))
      .Cells(lngR, 3) = ExecuteExcel4Macro(strRef & Range("B33").Range("A1").Address(, , xlR1C1))
      .Cells(lngR, 4) = ExecuteExcel4Macro(strRef & Range("B34").Range("A1").Address(, , xlR1C1))
      .Cells(lngR, 5) = ExecuteExcel4Macro(strRef & Range("I7").Range("A1").Address(, , xlR1C1))
      strFile = Dir
    Loop
    
  End With
  
End Sub

Gruß Sepp

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige