Dateien auf Verfügbarkeit prüfen ?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Selma!
Ungetestet!

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub CheckFileAndCopy()
Dim sHSrc As Worksheet, sHTar As Worksheet
Dim lngRow As Long, lngLast As Long
Dim rng As Range
Dim strPath As String

strPath = "H:\Import\2005\" 'Dateipfad mit "\" am Ende !
Set sHSrc = Sheets("Tabelle1") 'Tabelle mit den Dateinamen - Anpassen!
Set sHTar = Sheets("Import 2005") 'Zieltabelle

With sHSrc
  lngLast = .Cells(Rows.Count, 6).End(xlUp).Row
  For lngRow = 2 To lngLast
    If Dir(strPath & .Cells(lngRow, 6).Text) <> "" Then
      .Range(.Cells(lngRow, 1), .Cells(lngRow, 9)).Interior.ColorIndex = 4
      If rng Is Nothing Then
        Set rng = .Range(.Cells(lngRow, 1), .Cells(lngRow, 9))
      Else
        Set rng = Union(rng, .Range(.Cells(lngRow, 1), .Cells(lngRow, 9)))
      End If
    End If
  Next
End With

If Not rng Is Nothing Then rng.Copy sHTar.Cells(2, 1)

End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

hi
probier das mal aus
Option Base 1
Dim szFiles() As String
Option Explicit
Public


Sub exist()
Dim szName As String
Dim szDir As String
Dim i, nRow, j, x As Long
Dim index As Integer
For i = 1 To Sheets.Count
If Sheets(i).Name = "Import 2005" Then Exit For
Next i
index = i
nRow = 1        ' ist die zeilzeile in import 2005
szDir = "c:\Daten\2005\"
ReDim Preserve szFiles(1)
szFiles(1) = Dir(szDir + "*.*")
Do While szFiles(UBound(szFiles)) <> ""
' extension entfernen
szFiles(UBound(szFiles)) = Mid(szFiles(UBound(szFiles)), 1, _
InStr(szFiles(UBound(szFiles)), ".") - 1)
ReDim Preserve szFiles(UBound(szFiles) + 1)
szFiles(UBound(szFiles)) = Dir
Loop
ReDim Preserve szFiles(UBound(szFiles) - 1)
For i = 2 To 6382
' hole filename
szName = ActiveSheet.Cells(i, 6).Value
' ohne extension
szName = Mid(szName, 1, InStr(szName, ".") - 1)
For x = 1 To UBound(szFiles)
If szFiles(x) = szName Then
ActiveSheet.Range(ActiveSheet.Cells(i, 1), _
ActiveSheet.Cells(i, 9)).Interior.Color = RGB(0, 255, 0)
' und gleich kopieren
For j = 1 To 9
Sheets(index).Cells(nRow, j).Value = ActiveSheet.Cells(i, j).Value
Next j
nRow = nRow + 1
Exit For
End If
Next x
Next i
End Sub

mfg

Beliebteste Forumthreads (12 Monate)

Dateien auf Verfügbarkeit prüfen ?

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Dateien auf Verfügbarkeit prüfen ?

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread