Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 16.08.2017, 14:38   #1
ольгаг
Форумчанин
 
Регистрация: 22.02.2010
Сообщений: 325
По умолчанию Выбор файла по имени равному значению в ячейке

Здравствуйте Уважаемые программисты!
В файле excel 2003 во 2-ом столбце есть перечень имен сотрудников (ФИО), например 4-ре строки в столбце выглядят так:
Код:
1строка: Иванов Иван Иванович
2строка: Петров Сергей Сергеевич (прим.)
3строка: Отдел развития:
4строка: Сидоров Петр Петрович
...
т.е. в столбце в перемешку приведены ФИО сотрудников и название отделов, а также в конце ФИО может быть какой-нибудь текст.
В определенной папке лежат файлы типа "ФИО сотрудника.jpg" (Иванов Иван Иванович.jpg, Петров Сергей Сергеевич.jpg, Сидоров Петр Петрович.jpg).
Код ниже (vba) запрашивает эту папку и если находит файл jpg равный ФИО в ячейке столбца, то вставляет файл jpg как примечание к этой ячейке.
Подскажите пожалуйста как исправить код ниже, чтобы он работал в случае если в конце ФИО какой-нибудь текст, чтобы код искал среди имен файлов jpg в выбранной папке соответствующий ФИО ячейки текст? Иначе говоря, чтобы код сравнивал имена файлов jpg со значением в ячейке, и если в имени файла встречается значение из ячейки , то вставить примечание?

Код:
Sub test()
   Dim rngFoto As Range
   Dim fDialog As FileDialog
   Dim pFoto As String
   Dim i As Long
   Dim p As String
   Dim w As Long
   Dim h As Long

   Set rngFoto = Range(Cells(1, 2), Cells(Rows.Count, 2).End(xlUp))

   rngFoto.ClearComments

   Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
   With fDialog
      .Title = "Выберите папку с фото сотрудников:"
      .InitialFileName = "C:\"
      .AllowMultiSelect = False
      If .Show = -1 Then
         pFoto = .SelectedItems(1)
      End If
   End With
   Set fDialog = Nothing

   For i = 1 To rngFoto.Cells.Count
      p = pFoto & "\" & rngFoto.Cells(i, 1).Value & ".jpg"
      If Dir(p) <> "" Then
         w = LoadPicture(p).Width
         h = LoadPicture(p).Height
         With rngFoto.Cells(i, 1)
            .AddComment.Text Text:=""
            .Comment.Visible = False
         End With
         With rngFoto.Cells(i, 1).Comment.Shape
            .Fill.UserPicture p
            .ScaleWidth 1, msoFalse, msoScaleFromTopLeft
            .ScaleHeight h / w * 1.8, msoFalse, msoScaleFromTopLeft
         End With
      End If
   Next i
End Sub
Заранее спасибо!

Последний раз редактировалось ольгаг; 16.08.2017 в 14:46.
ольгаг вне форума Ответить с цитированием
Старый 16.08.2017, 15:35   #2
Serge_Bliznykov
Старожил
 
Регистрация: 09.01.2008
Сообщений: 26,238
По умолчанию

пробуйте:
Код:
Function IsInArrayFIO(stringToBeFound As String, arr As Variant) As Long
  Dim i As Long
  ' default return value if value not found in array
  IsInArrayFIO = -1

  For i = LBound(arr) To UBound(arr)
    If StrComp(Mid(stringToBeFound, 1, Len(arr(i)) - 4) & ".jpg", arr(i), vbTextCompare) = 0 Then
      IsInArrayFIO = i
      Exit For
    End If
  Next i
End Function


Sub FindAndInsertImages()
   Dim rngFoto As Range
   Dim fDialog As FileDialog
   Dim pFoto As String
   Dim i&, j&
   Dim p As String
   Dim w&, h&
   Dim arrFiles() As String
   Dim MyFile As String

   Set rngFoto = Range(Cells(1, 2), Cells(Rows.Count, 2).End(xlUp))

   rngFoto.ClearComments

   Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
   With fDialog
      .Title = "Выберите папку с фото сотрудников:"
      .InitialFileName = "C:\"
      .AllowMultiSelect = False
      If .Show = -1 Then
         pFoto = .SelectedItems(1)
      End If
   End With
   Set fDialog = Nothing
   
   ' прочитаем все jpg файлы в массив
    j = 0
    MyFile = Dir$(pFoto & "\*.jpg")
    Do Until MyFile = vbNullString
        ReDim Preserve arrFiles(j)
        arrFiles(j) = MyFile
        MyFile = Dir$()
        j = j + 1
    Loop
   

   For i = 1 To rngFoto.Cells.Count
      'p = pFoto & "\" & rngFoto.Cells(i, 1).Value & ".jpg"
      j = IsInArrayFIO(rngFoto.Cells(i, 1).Value, arrFiles)
      If j <> -1 Then
         p = pFoto & "\" & arrFiles(j)
         w = LoadPicture(p).Width
         h = LoadPicture(p).Height
         With rngFoto.Cells(i, 1)
            .AddComment.Text Text:=""
            .Comment.Visible = False
         End With
         With rngFoto.Cells(i, 1).Comment.Shape
            .Fill.UserPicture p
            .ScaleWidth 1, msoFalse, msoScaleFromTopLeft
            .ScaleHeight h / w * 1.8, msoFalse, msoScaleFromTopLeft
         End With
      End If
   Next i
End Sub
Serge_Bliznykov вне форума Ответить с цитированием
Старый 17.08.2017, 08:12   #3
ольгаг
Форумчанин
 
Регистрация: 22.02.2010
Сообщений: 325
По умолчанию

Спасибо!
ольгаг вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Загрузка PE-файла по адресу, равному ImageBase загрузчика Aoizora Win Api 3 24.07.2017 22:07
Обращение к массиву по значению в ячейке moonlight1 Общие вопросы Delphi 2 09.04.2017 09:17
Автоматическая замена имени файла в связанной ячейке ProkVS Microsoft Office Excel 0 29.12.2010 21:25
Макрос: часть имени файла прибавить к значению ячейки Обыватель Microsoft Office Excel 4 20.12.2010 19:41
ВПР - выбор файла в зависимости от имени Questru Microsoft Office Excel 19 08.12.2010 10:40