Страницы: 1
RSS
Перенос данных из xls в txt - c учетом даты
 
Доброго времени суток.
У меня возник вопрос. Помогите пожалуйста его решить.

Есть файл Данные.xls, в котором на листе находится таблица.
Таблица эта начинается с указания даты.

Как макросом перенести данные из этой таблицы - из диапазона C4:Y  - в файл "Прием данных.txt" в виде табулированного текста ?
Однако нужно переносить в txt - только новые строки -  те, дата которых более свежая, чем та, которая имеется в последней строке файла txt.

Например сейчас в txt - последняя строчка имеет дату - 9 дек 2017
А в таблице - позже этой даты строки - начинаются только с ячейки C7. То есть три вышестоящие строки - макросу нужно проигнорировать.
Я выделил пунктиром ту область, которую нужно перенести.
 
Код
Sub main()
    Dim arr(), i&, j&, txt$, ipath$
    ipath = ThisWorkbook.Path & Application.PathSeparator & "test.txt"
    arr = [c4:y15].Value
    For i = 1 To UBound(arr)
        For j = 1 To UBound(arr, 2)
            txt = txt & arr(i, j) & vbTab
        Next j
        txt = txt & vbNewLine
    Next i
    Open ipath For Output As #1
        Print #1, txt
    Close 1
    Shell "explorer " & ipath
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
Код
Sub Perenos()
    Dim fi, f, arr, i, u, dk, dv&, di&, d, m, y, ss
    Dim r, lr, ar
    fi = ActiveWorkbook.Path & "\" & "Прием данных.txt"
    f = Dir(fi)
    If Len(f) > 0 Then
        arr = Split(CreateObject("Scripting.FileSystemObject").Getfile(fi).OpenasTextStream(1).ReadAll, vbNewLine)
        For i = UBound(arr) To 0 Step -1
            If InStr(1, arr(i), vbTab) > 0 Then
            u = Split(arr(i), vbTab)
                If UBound(u) > 5 Then
                    d = (u(0))
                    m = (u(1))
                    y = (u(2))
                    dk = d & "." & m & "." & y
                    dv = DateValue(dk) ' нашли последнюю дату
                    Exit For
                End If
            End If
        Next i
        
        If dv > 0 Then
            Open fi For Append As 1
            With ActiveSheet
                lr = .Cells(.Rows.Count, 3).End(xlUp).Row
                ar = .Cells(1, 3).Resize(lr, 23).Value
                For r = 1 To lr
                    d = ar(r, 1)
                    m = ar(r, 2)
                    y = ar(r, 3)
                    If Len(d) * Len(m) * Len(y) > 0 Then ' если заполнены все поля
                        dk = d & "." & m & "." & y
                        di = DateValue(dk) ' нашли дату
                        If di > dv Then
                            ss = d & vbTab & m & vbTab & y
                            For i = 3 To UBound(ar, 2)
                                ss = ss & vbTab & ar(r, i)
                            Next i
                            Print #1, ss
                        End If
                        r = r + 2
                    End If
                Next r
            End With
            Close
        End If
        
    End If
End Sub
Изменено: Александр Моторин - 16.07.2019 09:42:43
 
Александр Моторин, Nordheim, спасибо за ответы.
Страницы: 1
Наверх