» Excel VBA

Anatolij2005

Код: n = ActiveCell.Row

Огромное спасибо!!!
Я был близок к разгадке, но у меня был Rows.....

Переношу сюда задачу от lucky_Luk из Excel FAQ foruma.
Начало обсуждения здесь.

Задача написать функцию подобную РАНГ (RANK), но чтобы не оставались пробелы в последовательности чисел.
Например для последовательности 5 3 7 3 6 8 2
РАНГ выдаст 4 2 6 2 5 7 1 (3 отсутствует)
Нужно 3 2 5 2 4 6 1

Функция РАНГ воспроизводится довольно просто (без последнего параметра, порядок только по увеличению):
Код: Function MyRank(num As Variant, reg As Range) As Long
Dim s As Long
s = 1
For Each c In reg
If num > c.Value Then
s = s + 1
End If
Next
MyRank = s
End Function

lucky_Luk
Мда, похоже никого задачка не заинтересовала. У меня был немного напряг со временем, но я ее все-таки добил. Код модуля ниже.

Алгоритм довольно простой:
1) Юзер выделяет область для ранжирования (1 столбец), запускает макрос. Соседний столбец справа должен быть пустой или данные заместятся. Проверки пока нет.
2) Данные копируются в массив
3) Массив сортируется
4) Удаляются дупликаты. Номер элемента в этом массиве и есть ранг соответствующей величины.
5) Исходные данные сравниваются с массивом. Соседний столбец заполняется рангами.

Код: Option Base 1

Sub RankIt()
If Selection.Columns.Count > 1 Then
MsgBox "You selected more then 1 column", vbCritical
Exit Sub
End If
'Some optimization
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Dim aArray() As Variant
Dim i As Long, c As Range
Dim rank As Long
Dim alen As Long

'Populate the array, sort and remove duplicates
ReDim aArray(Selection.Count)
i = 1
For Each c In Selection
aArray(i) = c.Value
i = i + 1
Next
SortArray aArray
RemoveDuplicates aArray

'Find values in the array
For Each c In Selection
rank = 1
Do While c.Value <> aArray(rank) And rank <= UBound(aArray)
rank = rank + 1
Loop
If rank > UBound(aArray) Then
MsgBox "Something wrong with the array"
Exit Sub
End If
Cells(c.Row, c.Column + 1).Value = rank
Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Done"
End Sub

Private Sub SortArray(ByRef a As Variant)
Dim i As Long, j As Long
Dim t As Variant

'standard bubble sort loops
For i = LBound(a) To UBound(a) - 1
For j = i + 1 To UBound(a)
If a(i) > a(j) Then 'change to < for descending order
t = a(i)
a(i) = a(j)
a(j) = t
End If
Next j
Next i
End Sub

Private Sub RemoveDuplicates(ByRef a As Variant)
Dim i As Long, j As Long
j = 1
Dim t() As Variant
ReDim t(1)
t(1) = a(1)
For i = LBound(a) To UBound(a) - 1
If a(i) <> a(i + 1) Then
j = j + 1
ReDim Preserve t(j)
t(j) = a(i + 1)
End If
Next i
ReDim a(j)
a = t
End Sub

Yuk
Макрос работает, спасибо. Можно ли сделать ранжирование в обратном порядке - чтобы самое большое число было на первом месте, а самое маленькое на последнем?

lucky_Luk
См. комент в функции сортировки.

Yuk

Цитата:

См. комент в функции сортировки.

Скажи пожалуйста какую строку смотреть и что с ней сделать. Ну не понимаю я в VBA .

lucky_Luk

Код: If a(i) > a(j) Then 'change to < for descending order

вопрос: как с помощью vba загрузить файл по ftp?

sleepy_frog
Гугл рулит, как всегда:
using vba to download file via ftp

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

Значения в первой строке будут меняться, но при нажатии на кнопку они всегда должны добавляться в конец. Попробовал записать макрос, вроде работает
Код:
Sub Макрос1()
Range("A1,B1,C1").Select
Selection.Copy
Range("A5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End Sub

mp3exchanger
Можно так:
Код: Cells(Range("A5").End(xlDown).Row + 1, 1).Select

Yuk вставив твою строку в свой макрос получил 1004 ошибку... а ты уверен, что ссылка на A5 в твоей строке нужна? Ведь мне понадобится копировать и в A7, A8, A9 и т.д.

mp3exchanger
Извиняюсь, недосмотрел. Ошибка выходит вначале, когда А5 или А6 пустые.
Один способ:
Код: If Range("A5").Value = "" Then
Range("A5").Select
ElseIf Range("A6").Value = "" Then
Range("A6").Select
Else
Cells(Range("A5").End(xlDown).Row + 1, 1).Select
End If

Yuk
Третий способ меня вполне устроил. Спасибо большое за помощь

Здравствуйте!

Я не силен в программировании под Exel, но возникла такая задача:
Есть таблица в Эксель, состоящаяя из двух колонок:
первая заполнена определенными числами,
задача состоит в том, чтобы при изменении ячейки во второй колонке к значению соответствующей ей ячейке в первой колонке прибавлялось введенное значение, а ячейка в которую вводили обнулялась.

Т.е. если проще: во второй колонке надо иметь возможность ввести значение на которое надо изменить (прибавить) значение из первой колонки.

Как это примерно реализовывается?

Здравствуйте!
Помогите, плз.
Задача такая:
есть таблицы в Excel их надо вставить в Power Point (как рисунок).
Просто скопировать и вставить не пойдет, надо автоматом - запустил макрос и таблицы в презентации.
думала просто запишу свои действия в макрос и все, но...
вот, что я делала:
1. есть Excel файл без связей, только значения.
2. задаю область печати (ту часть таблицы которая нужна для презентации)
начала записывать макрос
3. выделяю и копирую Область_печати (Ctrl+G; Ctrl+C)
4. вставляю в Power Point
завершила запись макроса.
в результате в макрос записался только пункт 3.
Если записывать макрос из под Power Point, то вставляется в презентацию то, что находится в буфере.

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

Заранее благодарю!

2Ona:
задача сложная. следует читать про оле-объекты. помоему по другому никак.
макрос не записывается,т.к. пишет только то что делается в Excel'e.
работать надо в направлении управления PowerPoint из Excel.

RobinStone
Скопируй в код листа (в VBA редакторе):

Код: Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Column = 2 Then
Cells(Target.Row, Target.Column - 1).Value = _
Cells(Target.Row, Target.Column - 1).Value + Target.Value
Target.Clear
End If
Application.EnableEvents = True
End Sub

Помогите ктонить! Подскажите пожалуйсто как работать с двоичными данными? Данные хранятся в базе я саздаю запрос а там такая вещ <BLOB Binary> и что с ней делать ненаю и как выковырять от туда нужные мне данные ?

Igor83o
Посмотри здесь, может поможет:
http://support.microsoft.com/default.aspx/kb/194975

как добраться до Properties в Global Contact List с Outlook'a в экселе?
я уже честно говоря уже в отчаянии..всё перерыл...нигде толкового ответа найти не могу.

RUSmafia
Да вроде в Гугле полно инфы по
Код: Excel VBA Outlook "Global Address List"

Yuk
Твой мактрос "RankIt" не пашет под русским Офис 97, при выполнении выдает ошибку, а отладчик ругается на строку "a = t". У кого есть Офис 97 проверьте пожалуйста, а то я до понедельника на работу не доберусь, а дома стоит 2003.

lucky_Luk
В 97-м офисе по другому работа с динамическими массивами. У меня его нет, так что извини.
Попробуй убрать () в строках:
Dim aArray() As Variant
и
Dim t() As Variant

проверено - работает

Подскажите пожайлуста: есть таблица в которой фамилии и возраст работников, надо создать цикл в котором Excel поочередно копировал бы фамилии и возраст работника из таблицы и вставлял их в другой лист и печатал. Если кто знает подскажите pliiiizzz.

Maks07
Другой лист - это бланк? Каждого работника надо печатать по отдельности?
Задача не сложная, но описание явно не достаточно. Попробуйте записать макрос и запустить его. Зайдите в VBA редактор (Alt-F11) и посмотрите на код. Для цикла надо будет использовать код типа:
Код: For Each row in ActiveSheet.UsedRange.Rows
newsheet.Cells(x1,y1).Value=row.Cells(1,name).Value
newsheet.Cells(x2,y2).Value=row.Cells(1,age).Value
Next

Да другой лист это бланк и работников печатать по отдельности. В нес данные отпечатал, внёс отпечатал итд. и так пока не кончится таблица.

[b]Maks07[/b]
Так макрос пробовал записать или нет? Будут проблемы, давай код сюда. Если сильно большой код, используй тег more: [more=какой-нибудь текст]код[/more].

Пример макроса, выполняется два повторения, нужно сделать цикл

Attribute VB_Name = "Module4"
Sub Макрос2()
Attribute Макрос2.VB_Description = "Макрос записан 03.07.2006 (Макс)"
Attribute Макрос2.VB_ProcData.VB_Invoke_Func = " \n14"
'
' Макрос2 Макрос
' Макрос записан 03.07.2006 (Макс)
'

'
Sheets("5-е отделение").Select
Range("C5").Select
Selection.Copy
Sheets("Приемная квитанция").Select
Range("B17:H17").Select
ActiveSheet.Paste
Sheets("5-е отделение").Select
Range("D5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Приемная квитанция").Select
Range("C27:D27").Select
ActiveSheet.Paste
Sheets("5-е отделение").Select
Range("C6").Select
Sheets("Приемная квитанция").Select
Application.CutCopyMode = False
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Sheets("5-е отделение").Select
Range("C6").Select
Selection.Copy
Sheets("Приемная квитанция").Select
Range("B17:H17").Select
ActiveSheet.Paste
Sheets("5-е отделение").Select
Range("D6").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Приемная квитанция").Select
Range("C27:D27").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Range("J16").Select
End Sub