title image


Smiley VBA Daten aus ident. Dateien in eine Datei übertragen
Hallo,



ich habe in einem Pfad identische Exceldateien (Reisekosten), die ich in einer einzelnen Datei zusammenfassen möchte. Die Daten stehen immer in der gleichen Zelle. Hab jetzt ein VBA Code der letztens noch lief, nun komischer Weise im neuen Jahr nicht mehr.



Problem:

Die Einzeldateien werden nicht geöffnet.



Vielleicht entdeckt ja jemnad einen Fehler :-)



Code:

Sub DateienAuslesen()

   Dim LW$, Datei$, tmp$

   Dim Liste() As String

   Dim x%

   Dim WB As Workbook

   Dim w As Worksheet

   

'  Pfad anpassen

   LW = "D:\Daten\Reisen\2006"

   Datei = "rk??????.xls"

   

   On Error Resume Next

   If Right(LW, 1) <> "\" Then LW = LW + "\"

   tmp = Dir(LW & Datei)

   Do While Len(tmp)

      x = x + 1

      With w

         ReDim Preserve Liste(x)

         Liste(x) = LW & tmp

      End With

      tmp = Dir()

   Loop

   On Error Goto 0

   

   Set w = ThisWorkbook.Worksheets("Tabelle1")

'  Alte Eintragungen löschen

   w.[b5:b65536] = ""

   w.[c5:c65536] = ""

   w.[d5:d65536] = ""

   w.[e5:e65536] = ""

   w.[f5:f65536] = ""

   w.[g5:g65536] = ""

   w.[h5:h65536] = ""

   w.[i5:i65536] = ""

   w.[j5:j65536] = ""

   w.[k5:k65536] = ""

   w.[l5:l65536] = ""

   w.[m5:m65536] = ""

   w.[n5:n65536] = ""

   w.[o5:o65536] = ""

   w.[p5:p65536] = ""

   w.[q5:q65536] = ""

   

   'Application.EnableEvents = False

   'Application.ScreenUpdating = False

   On Error Resume Next

   For x = 1 To UBound(Liste())

'     Debug.Print Liste(x)

      Workbooks.Open FileName:=Liste(x)



      Set WB = ActiveWorkbook

      

      w.Range("B65536").End(xlUp).Offset(1, 0).Value = WB.Worksheets("Reise").Range("E24").Value

      w.Range("C65536").End(xlUp).Offset(1, 0).Value = WB.Worksheets("Reise").Range("K24").Value

      w.Range("D65536").End(xlUp).Offset(1, 0).Value = WB.Worksheets("Reise").Range("Q24").Value

      w.Range("E65536").End(xlUp).Offset(1, 0).Value = WB.Worksheets("Reise").Range("W24").Value

      w.Range("F65536").End(xlUp).Offset(1, 0).Value = WB.Worksheets("Reise").Range("AC24").Value

      w.Range("G65536").End(xlUp).Offset(1, 0).Value = WB.Worksheets("Reise").Range("AI24").Value

      w.Range("H65536").End(xlUp).Offset(1, 0).Value = WB.Worksheets("Reise").Range("AO24").Value

      w.Range("I65536").End(xlUp).Offset(1, 0).Value = WB.Worksheets("Reise").Range("AU24").Value

      w.Range("J65536").End(xlUp).Offset(1, 0).Value = WB.Worksheets("Reise").Range("E27").Value

      w.Range("K65536").End(xlUp).Offset(1, 0).Value = WB.Worksheets("Reise").Range("Q27").Value

      

      TempVar = WB.Worksheets("Reise").Range("AB57").Value

      If TempVar <> "" Then

      w.Range("L65536").End(xlUp).Offset(1, 0).Value = TempVar

      Else

      w.Range("L65536").End(xlUp).Offset(1, 0).Value = "-"

      End If

      

      TempVar = WB.Worksheets("Reise").Range("AH56").Value

      If TempVar <> "" Then

      w.Range("M65536").End(xlUp).Offset(1, 0).Value = TempVar

      Else

      w.Range("M65536").End(xlUp).Offset(1, 0).Value = "-"

      End If

      

      TempVar = WB.Worksheets("Reise").Range("AH57").Value

      If TempVar <> "" Then

      w.Range("N65536").End(xlUp).Offset(1, 0).Value = TempVar

      Else

      w.Range("N65536").End(xlUp).Offset(1, 0).Value = "-"

      End If

      

      TempVar = WB.Worksheets("Reise").Range("F68").Value

      If TempVar <> "" Then

      w.Range("O65536").End(xlUp).Offset(1, 0).Value = TempVar

      Else

      w.Range("O65536").End(xlUp).Offset(1, 0).Value = "-"

      End If

      

      TempVar = WB.Worksheets("Reise").Range("T65").Value

      If TempVar <> "" Then

      w.Range("P65536").End(xlUp).Offset(1, 0).Value = TempVar

      Else

      w.Range("P65536").End(xlUp).Offset(1, 0).Value = "-"

      End If

      

      TempVar = WB.Worksheets("Reise").Range("AK65").Value

      If TempVar <> "" Then

      w.Range("Q65536").End(xlUp).Offset(1, 0).Value = TempVar

      Else

      w.Range("Q65536").End(xlUp).Offset(1, 0).Value = "-"

      End If



     'w.Range("R65536").End(xlUp).Offset(1, 0).Value = WB.Worksheets("Reise").Range("E24").Value

      

      WB.Close SaveChanges:=False

   Next x

   On Error Goto 0

   'Application.EnableEvents = True

   'Application.ScreenUpdating = True

End Sub

Code eingefügt mit Syntaxhighlighter 1.14



Bild:

Viele Grüsse aus Bayreuth

Christian 

Lilly-Sophie -->meine kleine Tochter



geschrieben von

Anhang
Bild 12056 zu Artikel 562422

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: