» Excel VBA (часть 2)

добрый день
нужна ваша помощь.
есть такая задача :
имееться: имя пациента, дата прибытия, дата отбытия и палата.
нужно на соседнем sheet'e заполнить своеобразный каллендарь, который выгледит вот так :
201 202 203 204 205 206 207 208 209 210 301 302 303
2008.12.01 x
2008.12.02 x
2008.12.03 x x
2008.12.04 x x x
2008.12.05 x x
2008.12.06 x x
2008.12.07 x
2008.12.08 x
2008.12.09 x x
2008.12.10 x
2008.12.11
т.е. палата 201 занята с первого декабря по 4ое
палата 207 с 4 по 9ое
302 с 3ого по 6ое и с 9 и до 10ого
как это реализовать в виде макроса?
я как бы могу найти строку с датой отбытия и прибытия пациента, могу найти столбез с палатой, но вот как в писать в эту своебразную матрицу креситики(или как либо по другому отметить) в занятые палаты....

Alex209
На листе поместить кнопку и назначить ей макрос.
Вот как-то так...

Sub Перечень()
Sheets("Перечень").Select
End Sub

Вместо "Перечень" - свое наименование листа, куда надо перемещаться.

TURNSKIN85

Лист1
1-я строка ФИО, прибыл, убыл, палата
с 3-й строки - данные

Лист2 как у тебя, только .. даты идут с 3-й строки
палаты во 2-й строке со 2-го столбца ..

Sub Обработка()

Dim mat()
Sheets("Лист1").Select
Range("A3").Select
n = Range("A3").End(xlDown).Row - 2

ReDim mat(2, n)

For i = 1 To n

mat(0, i) = Range("A3").Offset(i - 1, 1)
mat(1, i) = Range("A3").Offset(i - 1, 2)
mat(2, i) = Range("A3").Offset(i - 1, 3)

Next

Sheets("Лист2").Select

For i = 1 To n

k = mat(1, i) - mat(0, i)

Range("B2:K2").Select '**********
Selection.Find(What:=mat(2, i), After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
n1 = ActiveCell.Column

Range("A3:A33").Select '************
Selection.Find(What:=mat(0, i), After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
r1 = ActiveCell.Row
Range(Cells(r1, n1), Cells(r1 + k, n1)) = "*"

Next
Range("A1").Select
End Sub

там, где * - можно ПОКОЛДОВАТЬ ...

TURNSKIN85
Находишь сроку с датой и столбец с палатой
Обозначим n-номер строки с датой, m-номер столбца с палатой
cells(n,m)="x"

Mont1
спасибо за ответ, но как вытянуть номер столбца и строки из FoundCell ?

Код: Set FoundCell = Worksheets("Sheet2").Range("A1:A63").Find _
(what:=DateValue("2008.12.09"), LookIn:=xlFormulas)
Worksheets("Sheet3").Range("A10") = FoundCell
FoundCell.Interior.Color = RGB(10, 0, 0)

Народ, вы такими функциями оперируете, уделите пожалуйста минутку...
Не могу понять почему изменяются формулы когда меняются местами ячейки которые они используют... Символ $ тоже не помогает... Макрос описан выше...

ITradar

а так разве не РАБОТАЕТ?

a1 = Range(ActiveCell, ActiveCell).Value
a2 = Range(ActiveCell, ActiveCell).Offset(0, 1).Value

b1 = Range(ActiveCell, ActiveCell).Offset(-1, 0).Value
b2 = Range(ActiveCell, ActiveCell).Offset(-1, 1).Value


Range(ActiveCell, ActiveCell).Value = b1
Range(ActiveCell, ActiveCell).Offset(0, 1).Value = b2

Range(ActiveCell, ActiveCell).Offset(-1, 0).Value = a1
Range(ActiveCell, ActiveCell).Offset(-1, 1).Value = a2

TURNSKIN85
Я незнаю как работает оператор Find, предлагаю другой способ

Dim FoundCell As Range
For Each FoundCell In Range("A1:A63")
If FoundCell.Value = "09.12.2008" Then
m = FoundCell.Column 'Номер столбца
n = FoundCell.Row' Номер строки
End If
Next

Спасибо ОГРОМНОЕ за уделенное внимание. Всё отлично получилось! Привожу полностью завершенное решение, надеюсь табличка с этими макросами будет полезна при планировании покупок, расходов, или просто для планирования решения задач по степени их важности!

Sub SelectedUP()
'
' SelectedUP Макрос
' Макрос записан 18.10.2008 (Radmir)
'
' Сочетание клавиш: Ctrl+Shift+J
'

Dim UpRow As Integer

UpRow = Selection.Row
If UpRow > 3 Then
a1 = Cells(UpRow, 2): a2 = Cells(UpRow, 3)
Cells(UpRow, 2) = Cells(UpRow - 1, 2): Cells(UpRow, 3) = Cells(UpRow - 1, 3)
Cells(UpRow - 1, 2) = a1: Cells(UpRow - 1, 3) = a2
Cells(UpRow - 1, 2).Select
Else
MsgBox ("Приоритет наивысший!")
End If


End Sub


Sub SelectedDown()
'
' SelectedDown Макрос
' Макрос записан 10.12.2008 (Radmir)
'
' Сочетание клавиш: Ctrl+Shift+M
'

Dim DownRow As Integer

DownRow = Selection.Row
If (DownRow > 2) And (Cells(DownRow + 1, 2) <> "") Then
a1 = Cells(DownRow, 2): a2 = Cells(DownRow, 3)
Cells(DownRow, 2) = Cells(DownRow + 1, 2): Cells(DownRow, 3) = Cells(DownRow + 1, 3)
Cells(DownRow + 1, 2) = a1: Cells(DownRow + 1, 3) = a2
Cells(DownRow + 1, 2).Select
Else
MsgBox ("Выберите не пустую строку!")
End If

End Sub

Добавлено:
WowGun

Цитата:

а так разве не РАБОТАЕТ?

Так как Вы предложили меняет местами любые ячейки которые выделены, если случайно таким образом поменять формулы, то эту ошибку не сразу можно заметить... Спасибо за Вашу идею!

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

Всё, уже разобрался:

Код: ActiveCell.Replace What:="""", Replacement:=""

TURNSKIN85

Цитата:

спасибо за ответ, но как вытянуть номер столбца и строки из FoundCell ?

Код:
Set FoundCell = Worksheets("Sheet2").Range("A1:A63").Find _
(what:=DateValue("2008.12.09"), LookIn:=xlFormulas)
Worksheets("Sheet3").Range("A10") = FoundCell
FoundCell.Interior.Color = RGB(10, 0, 0)

if not FoundCell is nothing then
iRow=FoundCell.Row
iColumn=FoundCell.Column
end if

Люди !
Помогите. Простой вопрос, а ставит меня в затруднение.
Можно написать макрос который будет пермещать табличный курсор на на одну ячейку ниже. При условии что курсор неизвестно где будет стоять.Это нужно потому что после
автофильтра номера ячеек могут идти так 1,88,89,102. И мне надо попасть с 1 на 88 или 89. От 1 до88 ячейки скрыты. Может есть другие способы установить курсор наэти ячейки ?

vikas612

Цитата:

Можно написать макрос который будет пермещать табличный курсор на на одну ячейку ниже.

activecell.offset(1,0).activate

но зачем?


Цитата:

автофильтра номера ячеек могут идти так 1,88,89,102.

определяешь диапозон, н-р,

set rBereich=thisworkbook.worksheets(strMySheetName).range("A2:A1000")

for each zelle in rBereich.cells
if zelle.entirerow.hidden=false then
'твои действия
end if

next zelle

и т.д.

Доброе время суток!
Тут уже был ответ на вопрос : Найти "чужое" окно и нажать в нем кнопку.
А как можно реализовать то же самое, если окно запущено из VBA (макроса). Там похоже совсем другой класс окна (типа THunderDFrame), а кнопки, Textbox-ы и тд вообще "без окон".

в excel файле один лист невидимый, так как в редакторе vba видны три листа.(хотя фактически их 2)
При попытке в редакторе VBA, изменить свойство листа на -1 xlsheetvisible(а было до этого 0 xlsheethidden) выдает сообщение нельзя установить свойство visible класса worksheet. стандыртными средствами excel пробовал не катит.

ребя, кто шарит в регулярных выражениях? Помогите написать макрос или функцию, чтоб заменить все URLы в ссылках (кроме ссылок на изображения) на один URL например google.com (образец текста см. под катом)

[more]
[no]

Порно ролики можно скачать с высокой скоростью


hard_porn2-19.avi ~ 5.57MB
anal_porn9-16.avi ~ 2.92MB
hard_scene7-19.avi ~ 5.42MB
girls_part5-11.mpg ~ 9.71MB


Для выбора ролика кликните

У нас есть порно видео на любую тему:

книги игорь вагин порно фото девочек 15 16лет голая kyla cole исилькуль знакомства мастурбация мужчин частное секс фото большая грудь эротика фото icq чат порно ролик скрытая камера бесплатные видео порно ролики
секс мир видео культура анального секса порно 18 летних видео эротика азиатки добавить влад топалов секс-видео порно скачать sms женская грудь эротика лучший порно сайт видео порно видео галереи детское бесплатная домашняя порнуха скачать порно нижнего-новгорода видео сексуального изнасилования фото мужчины эротика скачать порно лесби видео порно видео лунка 1
руское порно фотки порно фото юлии ковальчук группа блестящие интим секс порно анальный секс стимуляция секс видео стариков галерея порно гинеколог фото порно мать посмотреть порно фильм с еленой берковой порно фтп голые попки молодые
секс видео трансвеститов секс японок видео скачать 3gp порноролики эротика заворотнюк видео эротика животными журналы pdf эротика скачать домашнее порно форум любителей порнухи малолетки эротика старушек
порно видео с волочковой эротика фото предосмотр порно видео клипы русские видео ролики порно рассказы порно ролики реклама порно школьницы видео смотреть секс истории малолетки анальный секс порнорассказы портал эротика 18 видео секс конем flash приколы эротика порно секс видео смотреть скачать рисованное порно видео клип эротика вагинально анальная пробка порно отрывки видео фото порнухи инцест секс эротика фильм бесплат порно видео бесплатнoe секс видео порно анфиса чехова видео видео ролики с порно порно скачать здесь эротика видео сейчас скачать порновидео avi бесплатно
[/no]
[/more]


Добавлено:
[no] то есть требуется програмно заменить произвольный текст между"[url=http://" и ближайшей закрывающей скобкой "]" на свой, заданный - так наверно можно ещё сформулировать[/no]

ev_robert
ну так файл, наверное, защищен от изменений

crotoff

Цитата:

програмно заменить произвольный текст ... на свой, заданный

В классической Perl-редакции будет так:

Код: $s =~ s/\[url=http:.+?\]/твой текст замены/g;

Vitus_Bering
К сожалению Пёрла у меня нет. А можно ли в VBA это как-нибудь реализовать? Или просто с помощью функций Excel, я сам что-то не могу сообразить

crotoff
Вот это поможет.

Vitus_Bering
спасибо! то что надо

[no]оказывается в моём случае работает конструкция с "*"

Cells.Replace What:="[url=http://*]", Replacement:="[url=http://my_site.com]", LookAt:=xlPart [/no]

Помогите пожалуйста. Форматирую ячейки указывая rows(i),celss(y).font.bold=true
Делаю перенос в ячейке rows(i),celss(y).wraptext=true. Не могу найти команду увеличить строку в высоту в зависимости от длины содержимого, т.е. мне надо автоформат высоты

ZIPANDDAIL
.EntireRow.AutoFit

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

ZIPANDDAIL
для любого объекта типа Range как то:
Range("A1"), Selection ...

Selection.EntireRow.AutoFit

ZIPANDDAIL

Цитата:

поподробнее синтаксис

Автоформат по высоте всех строк на листе

Код:
Sub AutoFitRows()
Dim i As Integer
For i = 1 To ActiveSheet.UsedRange.Rows.Count
Rows(i).EntireRow.AutoFit
Next i

End Sub

Получилось, спасибо!
Можно ли в пронумеровать страницы Execl без слова "Cтраница" по умолчанию стоит "Страница 1".
Это можно сделать с помощью vba или есть какие-то команды в Execl.

ZIPANDDAIL
&[Страница]

Всем доброго времени!
Такой вопрос: есть необходимость получать дату не локального времени, а времени, заданного часового пояса(GMT или UTC)

пробую что то типа этого: Dim date2 As Date = Date.UtcNow , но выдает ошибку

Подскажите пожалуйста в чем может быть дело?
Работаю на VBA. EXcel 2007.

Спасибо

Здравствуйте.
вообщем имеем текстовый файл с данными которые нужно перенести в эксел.
это сделано.
на панели инструментов создана кнопка, которая вызывает этот макрос.(макрос запихан в корневую папку)
при нажатий на кнопку открывается диалог выбора файла.
мне надо сделать так, чтобы при выборе этого файла он открывался в этой же книге.
то есть я закрываю активную книгу(activWindow.Close) и открываюв этом же окне свой макрос.
Проблема в чем...
1)если я закрываю окно,запускаю макрос в этом окне, то следующий когда я нажму на кнопку, получается что я закрываю свой макрос и немогу его окрыть.он открывается и тут же закрывается(((

ActiveWindow.Close
If OpenWorkbook("макрос") = True Then
ActiveWindow.Activate
End If

2) пробовал вытащить имя книги и если имя книги "макрос" то не закрывать. теперь когда макрос откыт и снова нажать на кнопку, то он запустить опенДиалог. почти как мне надо.

'If (OpenWorkbook(name) = True) And (name <> "макрос.xls") Then
'ActiveWindow.Close
'End If

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

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

а сейчас у меня получается
в первом варианте: закрыл книгу, открыл макрос, посчитал и все. пока не создашь новую книгу, макрос мне свой не запустить.
во втором варианте: если нету книг открывает в этом окне, если книга есть открывает в другом окне.

извините за такое длинное письмо))) заранее спасибо. я юзер в Vba.
вот начало кода макроса. после открытия у меня все ок. помоги с окнами

Private Function OpenWorkbook(iName$) As Boolean
Dim iBook As Workbook
For Each iBook In Workbooks
If iBook.name = iName$ Then
OpenWorkbook = True
Exit Function
End If
Next
OpenWorkbook = False
End Function
Public Sub Import_provodki()
Dim TextLine As String
Dim i As Integer
Dim nlist As String, path_name As String
Dim name As String


ActiveWindow.Close
If OpenWorkbook("макрос") = True Then
ActiveWindow.Activate
End If

'If (OpenWorkbook(name) = True) And (name <> "макрос.xls") Then
'ActiveWindow.Close
'End If


ActiveSheet.EnableAutoFilter = True
ActiveSheet.Protect contents:=True, userInterfaceOnly:=True

Range("A2:K3000").Select
Selection.ClearContents

With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Show
path_name = .SelectedItems(1)
End With