копирование из txt файла в ячейки exel

[andreton]

Доброго времени суток!

Помогите, плиз, решить задачу! Может и решение моментальное уже есть?...

Имеется файл excel - file.xls, файл txt - file.txt, и папка с файлами jpg - images (все в приложении).

1) нужно из txt переместить инфу в exel, но строго так, как показано в file.xls. пример показан по двум позициям, таких позиций множество!

2)автоматически сделать записи в ячейках гипперссылками на эти же файлы в папке images

Желательно, чтобы эти две задачи выполнялись по очередности: сначала 1, потом 2.

[Hugo121]

Фотографий всегда по 3 штуки?
Или если нет - в конце всегда _n.jpg? И n всегда однозначное?
Хотя не важно.. Важно - после одинакового названия отеля всегда "_"? Надо же к чему-то привязаться...
Но это не значит, что я берусь делать

[andreton]

Количество может быть разным, но не больше 20 штук. А вот "_" всегда есть.

Help, кто знает, и кто берется...

[doober]

текстовый файл в одной папке с файлом XLS
В текстовике смените кодировку с USC-2 на ANSI ИНАЧЕ КИНА НЕ БУДЕТ

Sub Part_1()

Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim s, d, rez As String
Dim i As Long, m As Long

Set Txt = oFSO.OpenTextFile(ThisWorkbook.Path & "\file.txt", 1, False)
    i = l
    m = 1
   s = Replace(Txt.readline, Chr(9), "")
   
 d = Split(s, "_", -1)
 rez = d(0)

  Sheets("Лист1").Hyperlinks.Add Anchor:=Cells(i, m), Address:= _
         s, TextToDisplay:=s
Do
On Error GoTo 7
  s = Replace(Txt.readline, Chr(9), "")
  d = Split(s, "_", -1)
 If rez = d(0) Then
  m = m + 1
   Sheets("Лист1").Hyperlinks.Add Anchor:=Cells(i, m), Address:= _
         s, TextToDisplay:=s
 Else
 i = i + 1:m = 1
   Sheets("Лист1").Hyperlinks.Add Anchor:=Cells(i, m), Address:= _
         s, TextToDisplay:=s
 End If
  rez = d(0)
Loop
7
Set oFSO = Nothing
End Sub

[EducatedFool]

Вот ещё вариант:

Sub main()
    txt = ReadTXTfile(Replace(ThisWorkbook.FullName, "xls", "txt"))
    Dim coll As New Collection, stopscan As Boolean: On Error Resume Next
    For Each ro In Split(txt, vbNewLine)
        res = Split(Split(ro, "/")(UBound(Split(ro, "/"))), "_")(0)
        coll.Add CStr(res), CStr(res)
    Next
    CurrentRow = 0    ' номер строки, с которой начинается вставка данных
    For Each res In coll
        Err.Clear: i = 0: stopscan = False: CurrentRow = CurrentRow + 1
        While Not stopscan
            i = i + 1: txt = "images\" & res & "_" & i & ".jpg"
            If Dir(Replace(ThisWorkbook.FullName, ThisWorkbook.Name, txt)) <> "" Then
                Cells(CurrentRow, i).FormulaLocal = "=ГИПЕРССЫЛКА(""" & txt & """)"
            Else
                stopscan = True
            End If
        Wend
    Next
End Sub

Sub ClearAll()
    ActiveSheet.UsedRange.Clear
End Sub

Function ReadTXTfile(ByVal filename As String) As String
    Set fso = CreateObject("scripting.filesystemobject")
    Set ts = fso.OpenTextFile(filename, 1, True): ReadTXTfile = ts.ReadAll: ts.Close
    Set ts = Nothing: Set fso = Nothing
End Function

И пример в виде файла: (сохраните его под именем file.xls)



Внимание: как сказал doober, смените кодировку текстового файла на ANSI, иначе и в моём случае кина не увидите...

[andreton]

Спасибо, EducatedFool!
Ваш вариант сработал сразу же!

И Doober тоже thanks!
Но ваш вариант выдал ошибку
Вот здесь:

Sheets("Лист1").Hyperlinks.Add Anchor:=Cells(i, m), Address:= _
         s, TextToDisplay:=s

В чем может быть дело?

[doober]

Я не поставил обработку ошибок,значит в текстовике есть еще другой текс еили пустые строки