» Excel VBA (часть 3)

Цитата:

можно ли каким-либо образом указывать, строчку с каким номером надо прочитать?

Код:
Do While Not EOF(iFile)
i=i+1
if i=5 then Line Input #iFile, txt: exit do
Loop

aidomars
Очень медленно будет, т.к. файл большой, а искать мне надо не только вперёд, но и назад.

Пока остановился на таком варианте: создаю список адресов каждой строчки один раз для каждого файла:[more=Код]

Код: ' file_lines_map (0) = total lines, file_lines_map(>0) address of each line
Public Sub gen_map(ByVal file_number As Long, ByRef file_lines_map() As Long)
Dim curpos As Long, lines As Long, wt As String, max_lines As Long
curpos = Seek(file_number)
lines = 0
max_lines = 100
ReDim file_lines_map(0 To max_lines)


Seek #file_number, 1
Do While (Not (EOF(1)))
file_lines_map(lines + 1) = Seek(file_number)
file_lines_map(0) = lines
Line Input #file_number, wt
lines = lines + 1
If lines >= max_lines Then
max_lines = max_lines * 2
ReDim Preserve file_lines_map(0 To max_lines)
End If
Loop

Seek #file_number, curpos
End Sub

Народ! Нужен простейший расчет разницы между двумя датами с выдачей результатов в годах, месяцах, днях.
Типа
date1 = "01.01.2013"
date2 = "03.01.2013"
И надо чтобы выдало что то типа "Разница: 0 лет, 0 мес., 2 дней".

Думал задача банальная и уже давно есть много примеров в гугле, но сижу третий час читаю ссылки, а результата 0
Хотел вычесть просто date1-date2 и применить функцию Year - выдает непонятное значение.
Пробовал DateDiff("yyyy", Data1, Date2) - тоже выдает непонятное число...

Направьте, плиз, на путь истинный.

Добавлено:
Или, если это все же непросто, хотя бы как рассчитать количество полных лет между датами?

Вот стандартными функциями Excel просто и точно можно сделать, типа так:
=РАЗНДАТ(A1;B1;"y") & " лет", где в A1 и B1 введены 2 даты.

Есть еще метод Evaluate, в который вроде как можно запихать формулу из обычных функций Excel.
А вот как скрестить этих ежа и ужа?..

Lovec
может так подойдёт:

Код:
=СЦЕПИТЬ(ЦЕЛОЕ((B1-A1)/365);" года ";ЦЕЛОЕ((B1-A1-ЦЕЛОЕ((B1-A1)/365)*365)/30);" месяца "; B1-A1-ЦЕЛОЕ((B1-A1)/365)*365-ЦЕЛОЕ((B1-A1-ЦЕЛОЕ((B1-A1)/365)*365)/30)*30; " дней")

LaCastet
Что-то крутое...
Но мне то надо на vba. Стандартными функциями Excel и "РАЗНДАТ" как я писал выше делает все идеально.

Lovec

Тогда, возможно, подойдет такой код (формат "год, месяц, день"):
[more]
Код:
Dim Data1 As Date, Data2 As Date
Dim d As Integer, M As Integer, G As Integer
'
If Data1 > Data2 Then
    M = DateDiff("m", Data2, Data1)
    d = DateDiff("d", Data2, DateAdd("m", -M, Data1))
Else
    M = DateDiff("m", Data1, Data2)
    d = DateDiff("d", Data1, DateAdd("m", -M, Data2))
End If

If d < 0 Then
    M = M - 1
    d = d + 30
End If
    
G = M \ 12
M = M Mod 12

With txtResult
    If G > 0 And M > 0 And d > 0 Then
        .Text = CStr(G) & " г. " & CStr(M) & " мес. " & CStr(d) & " д."
    ElseIf G > 0 And M > 0 And d < 1 Then
        .Text = CStr(G) & " г. " & CStr(M) & " мес. "
    ElseIf G > 0 And M < 1 And d > 0 Then
        .Text = CStr(G) & " г. " & CStr(d) & " д."
    ElseIf G > 0 And M < 1 And d < 1 Then
        .Text = CStr(G) & " г. "
    ElseIf G < 1 And M > 0 And d > 0 Then
        .Text = CStr(M) & " мес. " & CStr(d) & " д."
    ElseIf G < 1 And M > 0 And d < 1 Then
        .Text = CStr(M) & " мес. "
    Else
        .Text = CStr(d) & " д."
    End If
End With

Сделал [more=класс]
Код: Private text_file_map() As Long
Private file_number As Long



Private Sub Class_Initialize()
file_number = 0
ReDim text_file_map(1 To 100)
End Sub

Private Sub Class_Terminate()
Erase text_file_map()
Close_file
End Sub

Public Sub Close_file()
If file_number > 0 Then Close #file_number: file_number = 0
End Sub

Public Function file_num() As Long
file_num = file_number
End Function

Public Sub Open_file(filename As String)
Close_file
file_number = FreeFile(0)
Open filename For Input As #file_number
End Sub

Public Sub get_text_line(ByVal line_number As Long, ByRef text As String)
If file_number <= 0 Then Exit Sub

Dim size As Long
size = UBound(text_file_map)
If size > line_number Then '!!! size >= line_number+1
If text_file_map(line_number) > 0 Then
Seek #file_number, text_file_map(line_number)
Line Input #file_number, text
Exit Sub
End If
Else
If line_number < size * 2 Then size = size * 2 Else size = line_number * 2
ReDim Preserve text_file_map(1 To size)
End If
Dim cur_line As Long
cur_line = 1

Do While (text_file_map(cur_line) > 0)
cur_line = cur_line + 1
Loop

If cur_line = 1 Then text_file_map(1) = 1: cur_line = cur_line + 1

Seek #file_number, text_file_map(cur_line - 1)
Line Input #file_number, text
If EOF(file_number) Then Exit Sub
text_file_map(cur_line) = Seek(file_number)

' cur_line указывает на пустой адрес text_file_map(), который надо заполнить
Dim i As Long
For i = cur_line To line_number
Line Input #file_number, text
If EOF(file_number) Then Exit Sub
text_file_map(i + 1) = Seek(file_number)
Next i

End Sub

Lovec

Цитата:

как рассчитать количество полных лет между датами?

Пусть, например, date1 = "05.01.2013" и date2 = "03.01.2016"
Применив
Код: x = DateDiff("yyyy", date1, date2)

Подскажите плз с вопросом На панель инструментов Excel выведена кнопка, которая вызывает макрос из PERSONAL.XLS. Открывается форма, которая обрабатывает текущую открытую книгу (допустим Книга 1). На форме есть 3 текстбокса куда вручную задаются некие условия для дальнейших рассчетов. Например в текстбокс 3 нужно внести количество заполненных ячеек в стобце A Книги 1. Эти условия в принципе с помощью формул можно получить из той же Книги 1 которая обрабатывается.
Собственно вопрос в следующем. Как при вызове и инициализации формы из PERSONAL.XLS заставить ее посчитать 3 значения из Книги 1 и заполнить ими соответсвующие текстбоксы на форме?

Цитата:

Как при вызове и инициализации формы из PERSONAL.XLS заставить ее посчитать 3 значения из Книги 1

Код: Private Sub UserForm_Activate()
TextBox1 = ActiveWorkbook.Sheets(1).Cells(1, 1)
End Sub

Подскажите пожалуйста, как можно проверить, емеется ли в ячейке гиперссылка или нет.
т.е. if (гиперссылка в этой ячейке имеется) then...
else

sssssp

Цитата:

If Cell.Hyperlinks.Count = 0 Then
===================
Else

вот кстати и пример есть http://www.cyberforum.ru/vba/thread314881.html

Уважаемые ГУРУ программирования, может кто нибудь помочь в одном нелегком вопросе:
Вообщем есть таблица с данными, при нажатии на кнопку вылазит форма на которой требуется ввести номер базовой станции, далее при нажатии на кнопку "ок" должен открыться новый экселевский документ а в нем другая таблица, некоторые строки которой должны быть заполнены по данным из первой таблицы. Вот как то так, помогите пожалуйста, буду очень признателен.

День добрый. В C++ есть такая штука, как __attribute__((packed)), позволяющая выключить выравнивание в памяти данных конкретной структуры. Есть ли в VBA что-то похожее? Пишу программу, которая работает с DLL. Бейсик вставляет "дыры" между данными структуры, которую надо потом передать DLL.

Если нет отключения выравнивания, то какой универсальный (красивый) способ можете порекомендовать для преобразования структуры в набор байтов без дыр для последующей передачи?

Vasyatka91

Сервис / Макрос / Создать - выполни нужные тебе действия с данными, а потом уже в редакторе VBA оптимизируй/добавляй кнопку/форму...

дак дело в том что я в этом VBA совсем не бум бум((

Vasyatka91
1) Включаем на ленте меню разработчика.
2) Находим и вставляем на лист кнопку.
3) Alt + F11
4) Добавляем в проект модуль и форму.
5) Пишем в модуле -
Sub UFShow
UserForm1.Show
End sub
6) На кнопку назначаем макрос UFShow
7) На форму вставляем текстовое поле и кнопку.
8) В коде формы пишем:


Private Sub CommandButton1_Click()
Dim oWB As Workbook
Set oWB = Workbooks.Open("C:\Test.xls")
oWB.Worksheets("Sheet1").Range("A1:A10").Value = ThisWorkbook.Worksheets("Sheet1").Range("A1:A10").Value
End Sub

Вроде все. Пробуйте.

andrewkard1980
если я правильно понял данный код копирует данные с одной страницы и новый файл другой страницы, при нажатии на кнопку. Но у меня немного сложнее...Вот допустим у меня есть таблица с данными, и есть шаблон. Дак вот, при нажатии на кнопку у меня вылазит форма, в ней нужно указать номер базовой станции, далее при нажатии на кнопку "ок" должен открыться новый файл, а в нем заполненный шаблон именно для той базовой станции номер которой я указал. То есть определенные ячейка из таблицы должны скопироваться в определенные ячейка в шаблоне. Ну вот как то так

Vasyatka91
Т.е. в зависимости от введенного номера базовой станции меняется шаблон?
Тогда как то так:
Private Sub CommandButton1_Click()
Dim oWB As Workbook
Dim sFileName$

sFileName="C:\" & Userform1.textbox1 & ".xls"
Set oWB = Workbooks.Open( sFileName)
oWB.Worksheets("Sheet1").Range("A1:A10").Value = ThisWorkbook.Worksheets("Sheet1").Range("A1:A10").Value
End Sub

[more] andrewkard1980
я немного схитрил и сделал что бы надо было вводить не название базовой станции и строку в которой она находится, но хотелось бы все таки что бы работало с названием.
получился такой код: точнее его часть а то переменных 25ну осталось собственно скопировать данные в определенные ячейки в шаблоне.

Dim i As Integer
Dim p1 As String 'NodeB Name
Dim p2 As String 'Nodeb ID
Dim p3 As String 'Adjecent Node ID


i = 0
Rem NodeB Name
p1 = Range("A" & par).Offset(0, 4).Value

Rem Nodeb ID
p2 = Range("A" & par).Offset(0, 5).Value

Rem Adjecent Node ID
p3 = Range("A" & par).Offset(0, 6).Value

Но хотелось что бы было примерно так: нас просят ввести имя базовой станции в TextBox1, далее при нажатии кнопки "ok" нужно что бы код прочитал что было туда введено, далее он (код)) должен пробежать по таблице и сравнивая все ячейки с считанной, информацией, далее должен найти строку в которой есть совпадение, и как то уже работать с ней, вот думаю так было бы вообще идеально)

[/more]

Может кто подскажет навскидку, есть таблица с содержимым, цифровой код, наименование количество и т д, затем присылают этот же файл, но дополненный, как можно вывести только новые строки?

Добавлено:
Хотя наверное это проще макросом чем VBA

Можно создать кнопку, на нее записать макрос вставки строки и все.подробнее нажимаешь записать макрос, выделяешь строку, нажимаешь вставить, потом остановить макрос. вроде как то так

elite128
Если новые строки можно как то идентифицировать, то можно автофильтром, например.

Добавлено:
Vasyatka91
попробуйте, так Вы хотели?
http://rghost.ru/47316144

[more] andrewkard1980
я уже сделал, ну правда не так как хотелось, вот сделал как то так:
Private Sub CommandButton1_Click()
Dim par As Integer
par = TextBox1.Value

'/////////////////////////////////////////////////////////////////////////////////
Dim i As Integer
Dim p1 As String 'NodeB Name
Dim p2 As String 'Nodeb ID
Dim p3 As String 'Adjecent Node ID
Dim p4 As String 'Sybtrack No
Dim p5 As String 'Slot No

i = 0
Rem NodeB Name
p1 = Range("A" & par).Offset(0, 4).Value

Rem Nodeb ID
p2 = Range("A" & par).Offset(0, 5).Value

Rem Adjecent Node ID
p3 = Range("A" & par).Offset(0, 6).Value

Rem Sybtrack No
p4 = Range("A" & par).Offset(0, 7).Value

Rem Slot No
p5 = Range("A" & par).Offset(0, 8).Value

pathNewBook = "C:\Temp\" 'Путь сохранения новой книги
nameNewBook = "Base (" & Format(Now, "MMMM YYYY") & ").xlsx"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1 'количество листов в новой книге
Set NewWB = Workbooks.Add
ThisWorkbook.Activate
Sheets("Base").Copy Before:=NewWB.Sheets(1)
NewWB.Sheets(2).Delete


NewWB.SaveAs Filename:=pathNewBook & nameNewBook
NewWB.Close True 'Сохроняем
Application.CutCopyMode = False
If Dir(pathNewBook & nameNewBook) <> "" Then
MsgBox "Создан файл: " & pathNewBook & nameNewBook
Else
MsgBox "не удалось создать файл
End If
Workbooks.Open ("C:\Temp\Base (" & Format(Now, "MMMM YYYY") & ").xlsx") ' Открываем документ


Range("B4,C167").Value = p1 ' выделяем ячейки в которые необходимо произвести вставку, и вставляем
Range("C4").Value = p2
Range("B96").Value = p3
Range("D4").Value = p4
Range("E4").Value = p5

Unload Me

MsgBox "Complete", vbOKOnly, "Information"



вот как то так, но это только часть, вообще переменных 25) [/more]

Товарищи. Есть у кого функция перевода ФИО в творительный падеж? Буду благодарен.

Цитата:

elite128
Если новые строки можно как то идентифицировать, то можно автофильтром, например.

так файла 2, нужно сравнить строки в одном со строками в другом, и вывести что добавилось

Vasyatka91
Попробуйте как то так упростить ваш код,
в массиве можно хранить много переменных и место занимают меньше

Код:

Sub SearchRange()
Dim par%, lRw&, lCn&
Dim a, b
Dim sFileName$

par = UserForm1.TextBox1.Value
a = Range(Cells(1, par + 1), Cells(1, par + 5))
With ThisWorkbook.Sheets("Base")
lRw = .Cells.SpecialCells(xlLastCell).Row
lCn = .Cells.SpecialCells(xlLastCell).Column
b = .Range(.Cells(1, 1), .Cells(lRw, lCn))
sFileName = "C:\Temp\Base (" & Format(Now, "MMMM YYYY") & ").xlsx"
End With
Application.SheetsInNewWorkbook = 1
Set NewWB = Workbooks.Add
NewWB.Sheets(1).Range(Cells(1, 1), Cells(lRw, lCn)) = b

NewWB.SaveAs Filename:=sFileName$
NewWB.Close True
If Dir(pathNewBook & nameNewBook) <> "" Then
Workbooks.Open (sFileName$)
Range("B4,C167").Value = a(1, 1)
Range("C4").Value = a(1, 2)
Range("B96").Value = a(1, 3)
Range("D4").Value = a(1, 4)
Range("E4").Value = a(1, 5)
MsgBox "Complete", vbOKOnly, "Information"
Else
MsgBox "не удалось создать файл"
End If

UserForm1.Hide
End Sub

andrewkard1980
а можно как нить этот код:
Sub SearchRange()
Dim i&
Dim r As Range

For Each r In Worksheets("Лист1").UsedRange
If InStr(1, r.Value, UserForm1.TextBox1.Value) > 0 Then
MsgBox r.Row '
End If
Next
End Sub

вставить в мой
Dim par As Integer
par = TextBox1.Value

ну что бы переменной par присваивалось r.row, то есть вводилось бы название базовой станции, а код находил бы строку в которой она находится, и это значение присваивал параметру par
а упрощать как то не хочется, пусть уже так будет, я в нем более или менее понимаю что откуда берется))

Добавлено:
опечатался, не параметру par, переменной...

Vasyatka91
Замените MsgBox r.Row на par=r.Row

andrewkard1980
СПАСИБО ОГРОМНОЕ ЗА ПОМОЩЬ, все работает как и хотел!