Új hozzászólás Aktív témák

• #21879 Delila_1 veterán zhari #21859

  Új Válasz 2014-06-05 09:13:08 #21879

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz zhari #21859 üzenetére

  Nem tudtam megírni, egy régi kedves barátom segített ki.

  A teszt makróban a .StartFolder = "F:\" sorban írd át a meghajtó nevét a sajátodra, majd a ciklusban a jelzett részbe tedd be a másolást, és a megnyitott fájl bezárását. Ezt makrót kell indítanod. Bekéri a keresendő fájlok nevének azt a részét, ami közös, a példád szerint ez valami. A státuszsorban megjelennek a mappák, almappák, ahol a valami kezdetű fájlneveket keresi.

  Public Type TFindFile
  StartFolder As String
  FileName As String
  Extension As String
  Findings() As String
  ErrorCount As Long
  End Type

  Function FindFile(Args As TFindFile) As Boolean
  Dim Folders() As String, CurrentFolder As String, FolderLevel As Long
  Dim FN As String, LookUpName As String
  Dim i As Long, Maxi As Long, Mini As Long, FileFound As Boolean
  Dim Rng As Range
  
  With Args
  ChDrive Left(.StartFolder, 1)
  If Right(.StartFolder, 1) <> "\" Then .StartFolder = .StartFolder & "\"
  ReDim Folders(1)
  Folders(1) = .StartFolder
  FolderLevel = UBound(Split(.StartFolder, "\"))
  
  LookUpName = .FileName & "." & .Extension
  End With
  ReDim Args.Findings(0)
  Mini = 1
  
  On Error GoTo hiba
  Do
  Maxi = UBound(Folders)
  For i = Mini To Maxi
  FN = Dir(Folders(i) & LookUpName, vbNormal)
  While Not FN = ""
  FileFound = True
  ReDim Preserve Args.Findings(UBound(Args.Findings) + 1)
  Args.Findings(UBound(Args.Findings)) = Folders(i) & FN
  FN = Dir()
  Wend
  If UBound(Split(Folders(i), "\")) = FolderLevel Then
  FN = Dir(Folders(i) & "*.*", vbDirectory)
  While Not FN = ""
  If (FN <> ".") And (FN <> "..") Then
  If (GetAttr(Folders(i) & FN) And vbDirectory) <> 0 Then
  FN = Folders(i) & FN & "\"
  ReDim Preserve Folders(UBound(Folders) + 1)
  Folders(UBound(Folders)) = FN
  Application.StatusBar = FN
  End If
  End If
  FN = Dir()
  Wend
  End If
  DoEvents
  Next
  Mini = Maxi
  FolderLevel = FolderLevel + 1
  Loop Until Maxi = UBound(Folders)
  If FileFound Then FindFile = True
  Application.StatusBar = False
  Exit Function
  hiba:
  Set Rng = Sheets("Hibák").Range("A" & Rows.Count).End(xlUp).Offset(1)
  With Rng
  .Value = Folders(i)
  .Offset(, 1) = FN
  .Offset(, 2) = Err.Description
  .Offset(, 3) = Err.Number
  End With
  Args.ErrorCount = Args.ErrorCount + 1
  Resume Next
  End Function

  Sub teszt()
  Dim Args As TFindFile
  Dim Siker As Boolean, i As Long
  With Args
  '**************** itt a saját meghajtód nevét írd be! *******
  .StartFolder = "F:\"
  '****************************************************************
  .FileName = InputBox("fájlnév vagy része") & "*"
  .Extension = "xlsx"
  End With
  Siker = FindFile(Args:=Args)
  If Siker Then
  For i = 1 To UBound(Args.Findings)
  Workbooks.Open FileName:=Args.Findings(i)
  '****************************************************************
  ' ide jön a másolás, majd a behívott fájl bezárása
  '****************************************************************
  Next
  Else
  MsgBox "Nincs találat."
  End If
  If Args.ErrorCount > 0 Then
  MsgBox Args.ErrorCount & " probléma merült fel, lásd Hibák munkalap."
  End If
  End Sub

Új hozzászólás Aktív témák