@ Sepp: Größeres Projekt

Hallp Sepp,
ich habe noch zwei Probleme.
Ich würde gerne mittels eines Codes in einer Datei verschiedene hinterlegte Dateien öffnen. Die Dateinamen befinen sich um Bereich A2:A20 (wobei nicht alle Zellen belegt sein müssen). In Spalte B befindet sich das Tabellenblatt der enstprechenden Datei.
Dieses Tabellenblatt soll geleert werden. Anschliessend soll der Inhalt aus A25:cx reinkopiert werden. Einzufügen wäre der Inhalt ab A1. Anschliessend ist die Datei zu speichern.
In Spalte C der Ausgangsdatei soll der Status hinterlegt werden (geändert, Datum - Uhrzeit) oder Datei nicht gefunden oder geöffnet.
Wenn wir schon dabei wären, dann wäre es optimal, wenn in Spalte D meiner Ausgangsdatei jeweils ein Wert aus den Dateien eingetragen wird. Den Aufbau der zu öffnenenden Dateien musst Du Dir wie folgt vorstellen:
Reiter 1 irgendein Name
Dann 12 Reiter - der Name als Monat jeweils als Zahl (z.B. 01,02 usw)
In den Monatsreitern findest Du ab D1 bis AC1 die Tage, z.B. 1.10 oder 2.10 (Format Datum 14.3).
Abhängig vom Tagesdatum des Einlesens muss also geprüft werden, bei welchem Datum der letzte Eintrag vorhanden ist. Der Eintrag wird in der gleiche Spalte in Zelle 3 (D3 bis AC3) vorgenommen. Dabei ist entscheidendes Kriterium ob der Wert größer 0:00 ist.
Beispiel:
Tagedatum 15.05.2011
zuerst Reiter 05 prüfen, dann das Datum rausnehmen. Ist in 05 kein Wert größer 0 vorhanden dann Reiter 04 usw usw nehmen.
Hier mal meine Ausgangsdatei:

Die Datei https://www.herber.de/bbs/user/78100.xls wurde aus Datenschutzgründen gelöscht

Ist schon ein größeres Projekt. Auf alle Fälle vielen Dank, auch wenn Du vielleicht keine Lust hast.
Liebe Grüße
Claudia

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub getData() Dim objWb As Workbook Dim lngRow As Long, lngIndex As Long, lngCol As Long Dim strFile As String Dim fStatus As XL_FILESTATUS Dim vntret As Variant Dim blnDone As Boolean Me.Range("C2:D20") = "" For lngRow = 2 To 20 If Me.Cells(lngRow, 1) <> "" Then fStatus = FileStatus(Me.Cells(lngRow, 1)) If fStatus = XL_DONTEXIST Or fStatus = XL_UNDEFINED Then Me.Cells(lngRow, 3) = "Datei nicht gefunden! " & Format(Now, "dd.mm.yyyy - hh:MM:ss") ElseIf fStatus = XL_OPEN Then Me.Cells(lngRow, 3) = "Datei nicht verfügbar! " & Format(Now, "dd.mm.yyyy - hh:MM:ss") Else Set objWb = Workbooks.Open(Me.Cells(lngRow, 1)) If SheetExist(Me.Cells(lngRow, 2), objWb) Then With objWb.Sheets(Me.Cells(lngRow, 2)) .Cells.Clear Me.Range("A25").CurrentRegion.Copy .Range("A1") End With blnDone = False For lngIndex = Month(Date) To 1 Step -1 If SheetExist(Format(lngIndex, "00"), objWb) Then For lngCol = 29 To 4 Step -1 If objWb.Sheets(Format(lngIndex, "00")).Cells(3, lngCol) <> 0 Then Me.Cells(lngRow, 4) = objWb.Sheets(Format(lngIndex, "00")).Cells(3, lngCol) blnDone = True: Exit For End If Next End If If blnDone Then Exit For Next Me.Cells(lngRow, 3) = "Geändert! " & Format(Now, "dd.mm.yyyy - hh:MM:ss") objWb.Close True Else Me.Cells(lngRow, 3) = "Tabelle nicht vorhanden! " & Format(Now, "dd.mm.yyyy - hh:MM:ss") End If End If End If Next End Sub

Hallo Claudia,
mit Datei klappt's gleich besser;-))
Anbei der neue Code für das Tabellenmodul, läuft bei mir.

' **********************************************************************
' Modul: Tabelle1  Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Sub getData()
  Dim objWb As Workbook
  Dim lngRow As Long, lngIndex As Long, lngCol As Long
  Dim strFile As String
  Dim fStatus As XL_FILESTATUS
  Dim vntret As Variant
  Dim blnDone As Boolean
  
  On Error GoTo ErrExit
  GMS
  
  Me.Range("C2:D20") = ""
  
  For lngRow = 2 To 20
    If Me.Cells(lngRow, 1) <> "" Then
      fStatus = FileStatus(Me.Cells(lngRow, 1))
      If fStatus = XL_DONTEXIST Or fStatus = XL_UNDEFINED Then
        Me.Cells(lngRow, 3) = "Datei nicht gefunden! " & Format(Now, "dd.mm.yyyy - hh:MM:ss")
      ElseIf fStatus = XL_OPEN Then
        Me.Cells(lngRow, 3) = "Datei nicht verfügbar! " & Format(Now, "dd.mm.yyyy - hh:MM:ss")
      Else
        Set objWb = Workbooks.Open(Me.Cells(lngRow, 1))
        If SheetExist(Me.Cells(lngRow, 2), objWb) Then
          With objWb.Sheets(Me.Cells(lngRow, 2).Text)
            .Cells.Clear
            Me.Range("A25").CurrentRegion.Copy .Range("A1")
          End With
          blnDone = False
          For lngIndex = Month(Date) To 1 Step -1
            If SheetExist(Format(lngIndex, "00"), objWb) Then
              For lngCol = 29 To 4 Step -1
                If objWb.Sheets(Format(lngIndex, "00")).Cells(3, lngCol) <> 0 Then
                  Me.Cells(lngRow, 4) = objWb.Sheets(Format(lngIndex, "00")).Cells(3, lngCol)
                  blnDone = True: Exit For
                End If
              Next
            End If
            If blnDone Then Exit For
          Next
          Me.Cells(lngRow, 3) = "Geändert! " & Format(Now, "dd.mm.yyyy - hh:MM:ss")
          objWb.Close True
        Else
          Me.Cells(lngRow, 3) = "Tabelle nicht vorhanden! " & Format(Now, "dd.mm.yyyy - hh:MM:ss")
        End If
      End If
    End If
  Next
  
  ErrExit:
  GMS True
  
  If Err.Number <> 0 Then
    MsgBox "Fehler:" & vbTab & Err.Number & vbLf & vbLf & "Beschreibung:" & _
      vbLf & vbLf & Err.Description, vbInformation, "Fehler"
    Err.Clear
  End If
  Set objWb = Nothing
End Sub


Public Sub GMS(Optional ByVal Modus As Boolean = False)
  
  Static lngCalc As Long
  
  With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Not Modus Then lngCalc = .Calculation
    If Modus And lngCalc = 0 Then lngCalc = -4105
    .Calculation = IIf(Modus, lngCalc, -4135)
    .Cursor = IIf(Modus, -4143, 2)
    
  End With
  
End Sub

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread