Автоматизированный перенос данных

[IgorDn]

Добрый день.
Помогите пожалуйста разрешить следующую проблему с автоматизацией процесса.
Есть текстовая информация в следующем виде: ФИО………. Адрес………..номер тел………email……..
Необходимо данную информацию перенести в таблицу Excel, затем эти же данные вставить в нужные поля шаблона в Word, а затем перенести эти данные в текстовые поля браузера.
Так как данной информации очень много, физически невозможно всё это делать вручную. Заранее спасибо за помощь.

[EducatedFool]

Зачем такой сложный цикл переносов?
(TXT -> EXCEL -> WORD -> браузер)

попроще-то никак? зачем в браузер? дайте ссылку на страницу, куда надо вставлять эти данные, и напишите, что должно получиться.


1) Преобразование TXT -> EXCEL делается вручную, через опцию Excel «текст по столбцам»

2) EXCEL -> WORD (заполнение шаблонов) проще всего сделать этой программой:
http://ExcelVBA.ru/programmes/FillDocuments

3) для подстановки в поля браузера — готового решения нет.


PS: Можно сделать специализированный макрос, который все быстро сделает по нажатию одной кнопки, — но вряд ли кто возьмётся делать всё «от и до» бесплатно.

[IgorDn]

Такой цикл переносов нужен, потому что данные используются для разных целей потом. Изначально данные приходят в txt сплошной строкой. Вручную это можно делать когда объём небольшой, но сейчас такие действия приходится делать раз по 100 в день
Может подскажете, как можно разбирать текстовый файл и вставлять нужные слова в уже готовую таблицу excel? Например исходные данные в таком виде у меня:

[Hugo121]

Данные не в лучшем виде, имхо вывод писал плохой программист. Как минимум программист-эгоист...

Исходя из содержимого архива код:

Sub tt()

    Set fso = CreateObject("Scripting.FileSystemObject")
    MyPath = ThisWorkbook.Path

    Set ts = fso.OpenTextFile(MyPath & "\Данные.txt", 1)
    s = ts.ReadAll
    ts.Close

    For Each el In Array("ФИО: ", "адрес: ", "ФИО директора предприятия: ", "Вид деятельности: ")
        s = Replace(s, el, vbTab)
    Next
    
    a = Split(s, vbTab)

    ReDim b(1 To 1, 1 To 4)

    For i = 1 To 4: b(1, i) = a(i): Next

    ThisWorkbook.Sheets(3).Cells(Rows.Count, "A").End(xlUp)(2).Resize(1, 4) = b

End Sub

На практике думаю всё сложнее, но уж что показали

Можно уплотнить

Sub ttt()

    Set ts = CreateObject("Scripting.FileSystemObject").OpenTextFile(ThisWorkbook.Path & "\Данные.txt", 1): s = ts.ReadAll: ts.Close
    For Each el In Array("ФИО: ", "адрес: ", "ФИО директора предприятия: ", "Вид деятельности: "): s = Replace(s, el, vbTab): Next
    a = Split(s, vbTab): ReDim b(1 To 1, 1 To 4): For i = 1 To 4: b(1, i) = a(i): Next
    ThisWorkbook.Sheets(3).Cells(Rows.Count, "A").End(xlUp)(2).Resize(1, 4) = b

End Sub

[ABA2]

Добрый день.
Помогите ,пожалуйста:все также,но даные в *txt иные.
Спасибо.

[Hugo121]

ABA2, макрорекордер Вам в помощь:

Option Explicit

Sub Макрос1()
'
' Макрос1 Макрос
'

'
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;C:\Temp\ABA2\__LA_.txt", _
        Destination:=Range("$A$1"))
        .Name = "__LA_"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1251
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(2, 1, 1, 1, 5)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
End Sub

Можно конечно и мой код выше приспособить:

Sub ttt()

    Set ts = CreateObject("Scripting.FileSystemObject").OpenTextFile(ThisWorkbook.Path & "\__LA_.txt", 1)
    a = Split(ts.ReadAll, vbNewLine): ts.Close
    ReDim b(1 To UBound(a) + 1, 1 To 5)
    For i = 0 To UBound(a)
        If Len(a(i)) Then
            c = Split(a(i), vbTab): ii = ii + 1
            For x = 0 To UBound(c)
                If x = 3 Then b(ii, x + 1) = --(c(x)) Else b(ii, x + 1) = Trim(c(x))
            Next
        End If
    Next
    ThisWorkbook.Sheets(1).Cells(Rows.Count, "A").End(xlUp)(2).Resize(ii, 5) = b

End Sub

Только с форматом даты не понял - в тексте иначе. Сделал как в тексте. Ну это мелочи, можно подкрутить, если нужно...

[ABA2]

Уже в течение почти двух лет использоваю написан с макрорекордером-только с _Destination:=ActiveCell_ .Хотел красивее и без отметки,и вниз последовательно.Второй код очень подходит,за что -большое спасибо!
С уважением!

[Hugo121]

Ну можно и в том макрорекордерном кодом определить нужную ячейку (ThisWorkbook.Sheets(1).Cells(Rows. Count, "A").End(xlUp)(2))
У меня правда не получилось корректно скопировать кодировку (литовский?), вероятно нужно подкрутить в системе, или текстовый файл не совсем тот... Но мне это и не нужно
Да, и с датой посмотрите, всё ли устраивает - второй код даёт просто текст, вероятно нужно подправить.

[ABA2]

С датой все OK.
Просто забыл написать,что row 100 c данными.Толко Column 5 свободныи.

Как обойти?

[Hugo121]

Не понял. Что именно обойти?