» Excel VBA (часть 2)

kobelevs
На этой же странице (только 31), есть более простой код, он работает, для 12 столбца

Код:
For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
If Cells(i, 12).Value = 0 Then ActiveSheet.Rows(i).Delete
Next

Alexikit

Как раз то что нужно, работает - удаляет ненужные строки с нулями.
Спасибо.

Здравствуйте, помогите пожалуйста решить следующую задачу:
на листе excel имеются строки в первых ячейках которых значение "второй" строки зависит от значения в "первой", иногда приходится удалять "первую" строку, тогда во "второй" получается #ССЫЛКА!. Очень хочется, чтобы и вторая строка в этом случае тоже удалялась автоматически.
Спасибо

PSVRF

Что-то типа такого. Удаляет все зависимые от удаляемой ячейки, а также все последующие зависимые - по цепочке.
Вставить в модуль книги. Удалять либо строки, либо диапазоны "со сдвигом вверх".

Хотя, по-моему, это не самая лучшая идея.

Код: Public oDependentRange As Range, oRange As Range
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim sngW As Single
On Error Resume Next
If oRange Is Not Target Then
If Not oDependentRange Is Nothing Then
With oDependentRange
With .EntireColumn
sngW = .ColumnWidth
.AutoFit
End With
If .Text Like "*ССЫЛКА!*" Then
.Select
Debug.Print .Address 'Для контроля удаляемых диапазонов (смотреть в окне Immediate)
.Delete Shift:=xlShiftUp
End If
.EntireColumn.ColumnWidth = sngW
End With
End If
End If
Set oRange = Nothing
Set oDepndentRange = Nothing
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Set oRange = Target
On Error Resume Next
Set oDependentRange = Target.DirectDependents
End Sub

vlth
Спасибо, но код не работает.
Раз наскоком не получается решить, буду читать литературу, ещё раз спасибо.

У меня всё работает. Что не так? - подробнее можно?

Строки не удаляются, возможно не туда вставил код, хочу сам разобраться, поэкспериментирую, спасибо за направление.

Добрый день.
Как можно изменить все диаграммы находяшиеся на лист1?

этот код работает только если каждая диаграмма на отдельном листе, но мне нужно чтоб они были на лист1.

Sub nb()

Dim oChart As Chart
Dim nNach As Integer
Dim nKon As Integer

nNach = 1
nKon = 2501

For Each oChart In Charts

oChart.SeriesCollection(1).XValues = Range(Cells(nNach, 1), Cells(nKon, 1))
oChart.SeriesCollection(2).XValues = Range(Cells(nNach, 1), Cells(nKon, 1))
oChart.SeriesCollection(1).Values = Range(Cells(nNach, 2), Cells(nKon, 2))
oChart.SeriesCollection(2).Values = Range(Cells(nNach, 3), Cells(nKon, 3))

Next

End Sub
Что никто незнает? Хоть примерно подскажите.

Уважаемые форумчане! Подскажите такой нюанс:
В книге есть множество строк с данными. Мне нужно поменять строки местами для удобного просмотра, но так, чтобы не нарушить их порядок. Т.е., к примеру после строки 15 поставить строку 20 и получить примерно такой вид 15,20,16,17 и тд. Просто вставить между строк нельзя, т.к. к каждой цифре привязан макрос и при их смещении будет выполняться не тот, что нужно...Возможно ли это сделать? Если нет, подскажите, можно ли привязать макрос к конкретной ячейке, чтобы он "съезжал" за ней и как?
Пример одного их моих макросов:

If Not Intersect(Target, Range("D15")) Is Nothing Then
Application.EnableEvents = False
If Range("D15").Value = "есть" Then
Копи15
б51
End If
If Range("D15").Value = "нет" Then
Копи15
б52
End If
Application.EnableEvents = True
End If

Что мне нужно подправить, чтобы D менялось в соответствии измененной позицией ячейки?
ПС Конечно предпочтительнее услышать версию о замене номера строки, если это конечно, возможно. Благодарю.

Можно присвоить ячейкам имена и, предварительно скорректировав код, обращаться к ним в дальнейшем по имени:

If Not Intersect(Target, Range("Ячейка1")) Is Nothing Then
...

Добавлено:
Aleksandr185

Цитата:

Хоть примерно подскажите

Диаграммы на рабочих листах принадлежат семейству ChartObjects, а не Charts (диаграммы, расположенные на отдельных листах). Соответственно, их своиства и методы различаются.

Ребята помогите пожалуйста с решением.
Есть файл Excel в котором снятые с турникетов данные входа - выхода сотрудников офиса. Файл состоит из строк
1. Фамилия
2. Дата и время события
3. Направление (вход выход)
4. Остальные столбцы не информативны

Нужно создать макрос который позволит посчитать время, которое сотрудник отработал за деннь учитывая все входы и выходы и потом, просуммировав данные по дням, получить время отработанное за неделю.

Теоретически мне представляется это так - перегрупировать столбцы, чтобы входы и выходы были отдельными столбцами без потери всех связей (фамилия - дата - направление). Потом от выхода отнять соответствующий ему вход и полученные значения просумировать. Потом просуммировать все данные по дням получив данные за неделю. При ложном проходе (вход без выхода или выход без входа) весь проход ануллируется. Обьяснил как умею Как реализовать - не представляю. Для примера приложу пример файла отчета за пару дней.

Подскажите пожалуйста.
Ситуация такая:
У мня каждый месяц формируются .xls файлы, одинаковы по структуре.
В которых занесена информация.
Название вида: дд.мм.гг-Тут название файлы
В конце каждого месяца мне надо сформировать 1 общий .xls, в который будут копироваться данные из xls в данной папке.
Как или с помощью чего можно решить данный вопрос.

Спасибо.

vlth

Цитата:

Можно присвоить ячейкам имена и, предварительно скорректировав код, обращаться к ним в дальнейшем по имени:

If Not Intersect(Target, Range("Ячейка1")) Is Nothing Then

Благодарю. То, что нужно! иду копаться)

JekG

Код: Option Explicit
Sub prcEmplJobTimeCount(strSName As String)
Dim objSName As Range, intI As Integer, lngFRow As Long, lngLRow As Long
Dim aintWeeks() As Integer, asngHours() As Single, IntJ As Integer
Dim sngSumOfWeekHours As Single, intWeekN As Integer
Dim intMinutes As Integer, intHours As Integer

On Error GoTo ExitProc
With ThisWorkbook.Worksheets("Лист1")
' Предполагается, что все записи на листе отсортированы по фамилиям,
' а также, что искомая фамилия в таблице обязательно присутствует
' (иначе - ошибка и выход из программы):
lngFRow = .Columns(4).Find(strSName, LookIn:=xlValues).Row
IntI = lngFRow
Do While .Cells(IntI, 4) = strSName
IntI = IntI + 1
Loop
lngLRow = IntI - 1
Set objSName = Union(Range(.Cells(lngFRow, 2), .Cells(lngLRow, 2)), _
Range(.Cells(lngFRow, 8), .Cells(lngLRow, 8)))
End With

'objSName.Select 'Эта строка нужна только на момент отладки (выделяем все записи по сотруднику)

With objSName
For IntI = 1 To lngLRow - lngFRow
If .Cells(IntI, 7) = "Вход" And .Cells(IntI + 1, 7) = "Выход" _
And Day(.Cells(IntI, 1)) = Day(.Cells(IntI + 1, 1)) Then

intWeekN = DatePart("ww", .Cells(IntI, 1), vbMonday)
ReDim Preserve aintWeeks(IntJ): aintWeeks(IntJ) = intWeekN
ReDim Preserve asngHours(IntJ)
asngHours(IntJ) = DateDiff("s", .Cells(IntI, 1), .Cells(IntI + 1, 1)) / 3600

IntI = IntI + 1
IntJ = IntJ + 1
End If
Next IntI
End With

Set objSName = Nothing

sngSumOfWeekHours = asngHours(0)
intWeekN = aintWeeks(0)

For IntI = 1 To IntJ - 1
If intWeekN = aintWeeks(IntI) Then
sngSumOfWeekHours = sngSumOfWeekHours + asngHours(IntI)
Else
intHours = Val(sngSumOfWeekHours)
intMinutes = (sngSumOfWeekHours - intHours) * 60

'Вывод, к примеру, в окно отладки:

Debug.Print strSName & ", неделя "; Format$(aintWeeks(IntI - 1), "0#: ") _
& Format$(intHours, "0# ч") & ". " & Format$(intMinutes, "0# мин") & "."

intWeekN = aintWeeks(IntI)
sngSumOfWeekHours = asngHours(IntI)
End If
Next IntI

intHours = Val(sngSumOfWeekHours)
intMinutes = (sngSumOfWeekHours - intHours) * 60

'Вывод в окно отладки последней записи (если в таблице данных больше чем за 1 неделю):

Debug.Print strSName & ", неделя "; Format$(aintWeeks(IntI - 1), "0#: ") _
& Format$(intHours, "0# ч") & ". " & Format$(intMinutes, "0# мин") & "."

ExitProc:
'Обработку ошибок не делаю
If Err.Number <> 0 Then MsgBox "Ошибка:" & Err.Description
End Sub

Sub Test()
prcEmplJobTimeCount "Петрова"
End Sub

У книги есть связь с двумя книгами, например Book_1 и Book_2.
Как будет выглядить программный код, если я хочу прервать связь с Book_1

Only4You
Вашу задачу можно решить написав внешнюю программу, которая будет читать необходимые .xls файлы и записывать в один, это можно сделать например на VB. Или написать макрос в файле в который будет записываться информация, тогда из него будут отрываться необходимые файлы и записываться. Видимо Вам информацию из каждого файла надо записывать на отдельный лист.
Например слледующий код откроет четыре книги (Книга1.xls, Книга2.xls, Книга3.xls и Книга4.xls) и вставит считанную информацию на добавленные листы


Код:
Sub test1()
Dim book1 As Workbook
Dim list1 As Worksheet
Dim listak As Worksheet
Set xls = CreateObject("Excel.Application")
Dim nam As String
Dim nam1 As String
Dim a(2 To 12) As Double
Dim i, j As Integer
For j = 1 To 4 'задаем последовательность книг
nam1 = CStr(j)
nam = "D:\книга" + nam1 + ".xls"
Set book1 = xls.Workbooks.Open(nam) 'открываем книгу с данными
Set list1 = book1.Worksheets(1)
With book1
For i = 2 To 12
a(i) = Val(list1.Cells(i, 3)) 'читаем данные
Next
End With
book1.Close

With ActiveWorkbook
Set listak = ActiveWorkbook.Worksheets.Add ' добавляем листы
listak.name = "11_" + Str(j) ' С заданными именами
Set listak = ActiveWorkbook.Worksheets.Item("11_" + Str(j))
For i = 2 To 12
listak.Cells(i, 1) = a(i) ' вставляем данные в активную книгу
Next
End With
Next
xls.Quit
End Sub

Здравствуйте.
Задача простейшая, но додуматься как сделать что то не получается.
Есть 2 листа "zero" и "data"
На обоих листах есть столбцы например В с данными. Нужно получить на листе "data" стлбец C с результатами вычитания данных столбца на листе "data" из данных "zero".
Т.е. допустим формулой сие записывается просто, например в ячейке С2 пишем формулу "=B2-'zero'!B2" и т.д.
НО
Я хочу сделать пользовательскую функцию, что бы она задавалась видом например zeroing_oprion(B2) и производила это самое вычитание.

Как это сделаь поизящнее? Проблема еще в том, что параметром функции вроде как в програму передается значение ячейки, а не её адрес, так что что бы передать в скрипт адрес ячейки приходится записывать "=zeroing_oprion(ЯЧЕЙКА("адрес";В2))" и т.д.

Все это должно делаться как то очень просто, так что поможите плз

ЗЫ Вообще вся эта затея с пользовательской функцией из за того, что в каждом конкретном случае название "нулевого листа" может разнится, и его текущее имя хранится у меня в именванной ячейке "zero_sample"

Добавлено:
Пардон, все действительно легко и просто оказывается


Код:
Function zeroing_option(trubka_lev)
tr = Range("zero_sample").Value
zeroing_option = trubka_lev - Range(tr & "!" & trubka_lev.Address)
Application.Calculation = xlCalculationAutomatic
End Function

только вот опять туплю по простой задачке.
есть ячейка допустим R5C16 , нужно и ниже по столбику идут значения. Нужно определить последнюю заполненную ячейку и получить для формулы диапазон например R5C16:R31C16

Вообще все это нужно для подстановки в формулу

Код: Cells(2, 14).FormulaR1C1 = "=SUMX2MY2(R5C16:R11C16,R5C17:R11C17)"

Есть исходных файл XML в хз какой кодировке. VB его считывать с помощью XML DOM категорически отказывается, не видит данных.
При этом, если пересохранить этот же файл через Notepad в UTF8 все прекрасно читается.
Вопрос:
Как прочитать файл целиком (в виде текстового) и сохранить в кодировке UTF8, чтобы потом скормить XML DOM
strConv не помогает.

Ребят помогите пожалуйста началась зачетная неделя, а у меня висит макрос по экселю который я вообще не понимаю как сделать помогите кто может очень надо!

Вот задание!

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

Спасибо за внимание всем благодарен!

Помогите пожалуйста написать макрос для экселя......абсолютно не понимаю макросы......

Имеется столбец чисел неизвестной заранее высоты. Найти сумму тех элементов столбца, значения которых находятся в заданном диапазоне [X1, X2]. Числа X1 и X2 записаны в ячейки B1 и B2 соответственно. Результат записать в ячейку B3.

Как я поняла с столбце А записаны именно те значения которые надо проанализировать....

и мне надо сложить только те числа из столбца А, которые будут больше числа записанного в ячейке В1 но меньше числа в ячейке В2. Он должен выбрать еще что суммировать.Вот что мне нужно.

ludo4k2009
Sub Example()
Dim X As Double, Y As Double, Summa As Double
Dim i As Long: i = 1
With ThisWorkbook.Worksheets("Лист1")
X = .Cells(1, 2): Y = .Cells(2, 2)
Do Until IsEmpty(.Cells(i, 1))
If .Cells(i, 1) > X And .Cells(i, 1) < Y Then _
Summa = Summa + .Cells(i, 1)
i = i + 1
Loop
.Cells(3, 2) = Summa
End With
End Sub

СПАСИБО!!!!!!!!!!!!!!!!!!!!!!! все работает!! Вы просто жизнь спасли..

Excel 2003. Как кодом VBA "Пропустить ошибку" для текстовых цифр?
Подскажите пожалуйста.

pribush

Код: Sub Example()
Dim i As Long, k As Long, x As Long
With Thisworkbook.Worksheets("Лист1")
x = .UsedRange.Rows.Count 'вариант x=.cells(65536,1).end(xlup).row
For i = 1 To x
k = k + 1
If IsEmpty(.Cells(i + 1, 1)) Then
.Cells(i, 2) = k
If i = x Then Exit Sub
Do
i = i + 1
Loop While IsEmpty(.Cells(i, 1))
k = 1
End If
Next i
End With
End Sub

vlth
Немного разобрался с работой макроса. ВАш вариант не сработал изначально, потому пришлось его слегка подправить. Вышло вот что

Код: Option Explicit
Function prcEmplJobTimeCount(strSName As String)
Dim objSName As Range, intI As Integer, lngFRow As Long, lngLRow As Long
Dim aintWeeks() As Integer, asngHours() As Single, IntJ As Integer
Dim sngSumOfWeekHours As Single, intWeekN As Integer
Dim intMinutes As Integer, intHours As Integer

On Error GoTo ExitProc
With ThisWorkbook.Worksheets("Лист1")
' Предполагается, что все записи на листе отсортированы по фамилиям,
' а также, что искомая фамилия в таблице обязательно присутствует
' (иначе - ошибка и выход из программы):
lngFRow = .Columns(4).Find(strSName, LookIn:=xlValues).Row
intI = lngFRow
Do While .Cells(intI, 4) = strSName
intI = intI + 1
Loop
lngLRow = intI - 1
Set objSName = Union(Range(.Cells(lngFRow, 2), .Cells(lngLRow, 2)), _
Range(.Cells(lngFRow, 8), .Cells(lngLRow, 8)))
End With

'objSName.Select 'Эта строка нужна только на момент отладки (выделяем все записи по сотруднику)

With objSName
For intI = 1 To lngLRow - lngFRow
If .Cells(intI, 7) = "Вход" And .Cells(intI + 1, 7) = "Выход" _
And Day(.Cells(intI, 1)) = Day(.Cells(intI + 1, 1)) Then

intWeekN = DatePart("ww", .Cells(intI, 1), vbMonday)
ReDim Preserve aintWeeks(IntJ): aintWeeks(IntJ) = intWeekN
ReDim Preserve asngHours(IntJ)
asngHours(IntJ) = DateDiff("s", .Cells(intI, 1), .Cells(intI + 1, 1)) / 3600

intI = intI + 1
IntJ = IntJ + 1
End If
Next intI
End With

Set objSName = Nothing

sngSumOfWeekHours = asngHours(0)
intWeekN = aintWeeks(0)

For intI = 1 To IntJ - 1
If intWeekN = aintWeeks(intI) Then
sngSumOfWeekHours = sngSumOfWeekHours + asngHours(intI)
Else
intHours = Val(sngSumOfWeekHours)
intMinutes = (sngSumOfWeekHours - intHours) * 60

'Вывод, к примеру, в окно отладки:

Debug.Print strSName & ", неделя "; Format$(aintWeeks(intI - 1), "0#: ") _
& Format$(intHours, "0# ч") & ". " & Format$(intMinutes, "0# мин") & "."
prcEmplJobTimeCount = intHours
intWeekN = aintWeeks(intI)
sngSumOfWeekHours = asngHours(intI)
End If
Next intI

intHours = Val(sngSumOfWeekHours)
intMinutes = (sngSumOfWeekHours - intHours) * 60

'Вывод в окно отладки последней записи (если в таблице данных больше чем за 1 неделю):

Debug.Print strSName & ", неделя "; Format$(aintWeeks(intI - 1), "0#: ") _
& Format$(intHours, "0# ч") & ". " & Format$(intMinutes, "0# мин") & "."
prcEmplJobTimeCount = intHours
ExitProc:
'Обработку ошибок не делаю
If Err.Number <> 0 Then MsgBox "Ошибка:" & Err.Description
End Function

Sub Test()
Dim s, n, j, i, b, fam(1000) As String
n = 1
fam(1) = Range("D5")
i = 5
While Range("D" & i) <> ""
b = False
For j = 1 To n
If Range("D" & i) = fam(j) Then
b = True
End If
Next j
If Not b Then
n = n + 1
fam(n) = Range("D" & i)
End If
i = i + 1
Wend
Range("K5:M1663").Select
Selection.ClearContents
For i = 1 To n
s = prcEmplJobTimeCount(fam(i))
Range("K" & (5 + i)) = fam(i) + " проработал(а): "
Range("L" & (5 + i)) = s
Range("M" & (5 + i)) = "часов!"
Next i
End Sub

JekG

Цитата:

Немного разобрался с работой макроса

Цитата:

И еще макрос считает только час. Как сделать подсчет минут и секунд

asngHours(IntJ) = DateDiff("s", .Cells(intI, 1), .Cells(intI + 1, 1)) / 3600
Видимо, не очень разобрались : здесь, в этой строке, если убрать "/3600", получим секунды.


Цитата:

ВАш вариант не сработал изначально

Вообще код написан в кач-ве примера для обработки файла с представленными данными. Как я понимаю, то был фрагмент, по которому нельзя сделать однозначный вывод об их структуре в полном объёме.
Для приведённой Вами структуры код - внимание! - работает.


Цитата:

И еще не логичнее ли индентифицировать людей по номеру пропуска (в поле Отчество). Отрабатывать по уникальной цифре вроде проще чем по фамилии.

Согласен. Но как быть с этим:

Цитата:

Есть файл Excel в котором снятые с турникетов данные входа - выхода сотрудников офиса. Файл состоит из строк
1. Фамилия
2. Дата и время события
3. Направление (вход выход)
4. Остальные столбцы не информативны

Вы предлагаете участникам форума искать чёрную кошку в тёмной комнате? - Ваша задача - правильно сформулировать вопрос, снабдив его исчерпывающей информацией. Труд? - согласен. Но Вы ведь хотите получить ответ?

Господа!
Есть необходимость каждый день 5-6 файлов в формате Excel 2003 переформатировать в формат Excel 2007. Это уже надоело. Надо бы сделать макрос который все файлы с расширением .xls из данной папки пересохранит в формат .xlsx. При этом исходные файлы можно удалить. Функций, котрые за это отвечают я толком не знаю. Буду благодарен за советы.

vlth
Простите я ни в коем случае не пытался наезжать и обвинять. За помощь благодарю еще раз.
Если
Цитата:

здесь, в этой строке, если убрать "/3600"

Получили секунды а нужно, чч.мм.сс. И то посчитало почемуто только нескольких людей. У остальных выдало Overflow.
Насчет вводных уточняю -
С турникетов выгружаются
Файл состоит из строк
1. Статус
2. Дата и время события
3. № пр-ка
4. Тип пропуска (неинформативное)
5. Фамилия
6. Имя
7. Отчество (в этом поле прописан номер пропуска сотрудника. Он уникален для каждого и может служить для идентификации в случае одинаковой фамилии)
8. Отдел
9. Точка (неинформативное)
10. Направление (вход выход)
11. Зоны (неинформативное)

Так будет совсем точно. Отбирать можно по пп 3 или 7 (они уникальные для каждого)
Простите еще раз за это недоразумение.

JekG
Какое недоразумение? - я не сомневаюсь в отсутствии Ваших претензий ко мне: сие было бы... ну, не важно
Дело в другом: Вы ставите людям задачу, значит должны грамотно её сформулировать. Понятно, что это иногда бывает сложнее, чем её решить, но это - Ваша работа, от качества которой напрямую зависит, получите Вы ожидаемый результат, или нет.
Вот что я хотел до Вас донести своим ответом.

Вернёмся к процедуре...

1. Я ввёл в Вашу таблицу две строки, на что программка отреагировала ответом:

Код:
07.12.09 9:00:00        Клочкова
07.12.09 9:45:00        Клочкова

Результат:
Клочкова, неделя 50: 00 ч. 45 мин.