SaveText.Ru

Без имени
  1. Но если файлов много и все с разными именами, то это не очень практично и уж точно не компактно. А т.к. немногие начинающие могут сразу найти желаемое, я решил выложить код, который перебирает все файлы в папке и открывает их:
  2. Sub Get_All_File_from_Folder()
  3.     Dim sFolder As String, sFiles As String
  4.     'диалог запроса выбора папки с файлами
  5.     With Application.FileDialog(msoFileDialogFolderPicker)
  6.         If .Show = False Then Exit Sub
  7.         sFolder = .SelectedItems(1)
  8.     End With
  9.     sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
  10.     'отключаем обновление экрана, чтобы наши действия не мелькали
  11.     Application.ScreenUpdating = False
  12.     sFiles = Dir(sFolder & "*.xls*")
  13.     Do While sFiles <> ""
  14.         'открываем книгу
  15.         Workbooks.Open sFolder & sFiles
  16.         'действия с файлом
  17.         'Запишем на первый лист книги в ячейку А1 - www.excel-vba.ru
  18.         ActiveWorkbook.Sheets(1).Range("A1").Value = "www.excel-vba.ru"
  19.         'Закрываем книгу с сохранением изменений
  20.         ActiveWorkbook.Close True 'если поставить False - книга будет закрыта без сохранения
  21.         sFiles = Dir
  22.     Loop
  23.     'возвращаем ранее отключенное обновление экрана
  24.     Application.ScreenUpdating = True
  25. End Sub
  26.  
  27. Private Sub Command1_Click()
  28. Dim Mem(50) As String
  29. Dim Riven As Integer
  30. Dim StatusE As Boolean
  31. Dim objFSO As New FileSystemObject
  32. Dim Path As String
  33. Dim NextPath As String
  34. Dim objFolder As Folder
  35. Dim OstFolder As Boolean
  36.  Path = "D:Музика"  ' Указывайте сдесь свой путь
  37. che:
  38.     Set objFolder = objFSO.GetFolder(Path)
  39.     StatusE = False
  40.     For Each objFolder In objFolder.SubFolders
  41.         OstFolder = False
  42.         If Mem(Riven) = "" Then
  43.           StatusE = True
  44.           NextPath = objFolder.Name
  45.           Exit For
  46.         End If
  47.         If StatusE = True Then
  48.           NextPath = objFolder.Name
  49.           Exit For
  50.         End If
  51.         If Mem(Riven) = objFolder.Name Then
  52.           StatusE = True
  53.           OstFolder = True
  54.         End If
  55.     Next objFolder
  56.    
  57.    
  58.    
  59.     If StatusE = True And OstFolder = False Then
  60.       Mem(Riven) = NextPath
  61.       Riven = Riven + 1
  62.       Path = Path + NextPath + ""
  63.         List1.AddItem Path
  64.         List1.ListIndex = List1.ListCount - 1
  65.         DoEvents
  66.         StatusE = False
  67.     Else
  68.       If Riven = 0 Then Exit Sub
  69.       Mem(Riven) = ""
  70.       Riven = Riven - 1
  71.       Path = Left(Path, Len(Path) - 1)
  72.       NextPath = Mid(Path, InStrRev(Path, "") + 1)
  73.       Path = Left(Path, InStrRev(Path, ""))
  74.       StatusE = False
  75.     End If
  76. GoTo che
  77. End Sub
  78.  
  79. Private Sub Dir1_Change()
  80.   File1.Path = Dir1.Path ' было отключено
  81. End Sub

Share with your friends:

Print