» Excel VBA (часть 3)

Подскажите, пожалуйста, команду для такой операции: если в выделенном фрагменте имеются ячейки формата Date "[$-F800]dddd, mmmm dd, yyyy", то преобразовать их в дефолтный формат (dd/mm/yyyy).

Спасибо!

P.S.
И ещё, можно ли указать отсутствие любых линеек (borders) одной командой, а не так, чтобы писать отдельную строку для каждого вида линеек?

Lovec

Цитата:

Может есть способ улучшить алгоритм?

Drazhar

Цитата:

Lovec
имхо нет

ИМХО можно. Например, для столбца "A", так:

Код: Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Application.CountIf([A:A], Target) > 1 Then MsgBox "Повтор значения!"
End Sub

SAS888
Спасибо за countif

SAS888
Да, за Application.CountIf спасибо, не знал

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

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

Lovec

Цитата:

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

Хорошо. Но тогда что делать с теми ячейками, значения которых не уникальны в столбце? Вы этого не оговорили. Следующий код будет проверять пересечение вставляемого диапазона со столбцом "A", и в случае обнаружения ячеек с уже имеющимися значениями, окрашивать их в желтый цвет. А что Вам нужно?

Код: Private Sub Worksheet_Change(ByVal Target As Range)
Dim x As Range, y As Range: Set x = Intersect(Target, [A:A])
If x Is Nothing Then Exit Sub
For Each y In x
If Application.CountIf([A:A], y) > 1 Then y.Interior.ColorIndex = 6
Next
End Sub

SAS888 06:52 25-08-2010
Цитата:

Если в формат "dd/mm/yyyy" требуется преобразовать все ячейки выделенного диапазона, то можно так:

Спасибо, но проблема в том, что в выделенном диапазоне имеются также и ячейки с датами в других форматах, которые надо оставить как есть. То есть, преобразовать надо не все ячейки, а именно те, которые в исходном виде содержат дату в определенном формате (Date "[$-F800]dddd, mmmm dd, yyyy"), то есть, формула преобразования, вероятно, должна начинаться с условия If. Или так вообще нельзя сделать?

Относительно выходного формата тоже есть вопрос. Предложенная команда
Код: Selection.NumberFormat = "m/d/yyyy"

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

Спасибо.

Добавлено:
Вот еще.

Для выделения всего столбца используется оператор
Columns("B:B").Select

Как сделать тоже самое, если известна не буква столца, а его цифровой номер (в данном случае 2)?

oshizelly
Какой в Excel установлен формат даты по умолчанию, можно определить, используя свободную ячейку (в примере это "A1"). Устанавливаем "Общий" формат и помещаем в нее значение текущей даты. В результате, формат ячейки меняется на формат даты по умолчанию. Считываем этот формат в переменную и затем используем для работы. Временную ячейку очищаем. Т.е. примерно так:

Код: Sub Main()
Dim x As Range, s As String: Application.ScreenUpdating = False
[A1].NumberFormat = "General": [A1] = Date: s = [A1].NumberFormat: [A1].ClearContents
For Each x In Selection
If x.NumberFormat = "[$-F800]\d\d\d\d.\m\m\m\m \d\d.\y\y\y\y" Then x.NumberFormat = s
Next
End Sub

SAS888 06:52 25-08-2010
Цитата:

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

Код: For Each x In Selection.Borders: x.LineStyle = xlNone: Next

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

======================================
Sub macros1()

Set myDocument = Worksheets(2)
With myDocument.Shapes.AddLine(100, 100, 150, 100).Line
.DashStyle = msoLineDashDotDot
.ForeColor.RGB = RGB(50, 0, 128)
End With
End Sub
======================================

рисует линию по координатам на втором листе ( Worksheets(2) )
подскажите как работать с переменными - взять значение из второго листа из ячейки А2

такой вариант не прокатывает:

With myDocument.Shapes.AddLine(Worksheets(2).Cells(1, 2).Value, 100, 150, 100).Line

johnsmith57
Гм. А чем именнго не прокатывает такой вариант? У меня работает

Drazhar, у меня тоже теперь работает. Спасибо!

Осталось понять в каком порядке задаются координаты.
Ноль находится в верхнем левом углу, а вот как дальше...

Первая цифра - номер строки, вторая - номер столбца

Парни, а подскажите плз, кто-нибудь видел примеры программерских решений в Эксель завязанные на географические карты? Понятно, что это мягко говоря не его, но тем не менее, как форма визуализации.. Т.е. интересны графические способы представления завязанные на сопоставлении данных с координатами (скорее топорно-условными по адресам ячеек) и их визуализации на карте (например, отображение по фильтру информации об определенных объектах из баз данных, скажем в виде флажков, на уже готовой карте и т.д., короче, как бы такой географический OLAP). Спасибо!

Люди помогите подправить код

Цитата:

Sub NewSheet()
Dim iL As Long, shName As String, i As Integer
On Error GoTo errHandle:
Application.ScreenUpdating = False
ActiveSheet.Copy after:=ActiveSheet
shName = Format(Now, "DD.MM.YYYY")
i = 1
Do While ListName(shName) = True
shName = Format(Now, "DD.MM.YYYY") & "(" & i & ")"
i = i + 1
Loop
ActiveSheet.Name = shName
If Sheets(Sheets.Count - 1).Tab.ColorIndex = 2 Then ActiveSheet.Tab.ColorIndex = 3
If Sheets(Sheets.Count - 1).Tab.ColorIndex = 3 Then ActiveSheet.Tab.ColorIndex = 4
If Sheets(Sheets.Count - 1).Tab.ColorIndex = 4 Then ActiveSheet.Tab.ColorIndex = 5
If Sheets(Sheets.Count - 1).Tab.ColorIndex = 5 Then ActiveSheet.Tab.ColorIndex = 6
If Sheets(Sheets.Count - 1).Tab.ColorIndex = 6 Then ActiveSheet.Tab.ColorIndex = 7
If Sheets(Sheets.Count - 1).Tab.ColorIndex = 7 Then ActiveSheet.Tab.ColorIndex = 8
If Sheets(Sheets.Count - 1).Tab.ColorIndex = 8 Then ActiveSheet.Tab.ColorIndex = 9
If Sheets(Sheets.Count - 1).Tab.ColorIndex = 9 Then ActiveSheet.Tab.ColorIndex = 10
If Sheets(Sheets.Count - 1).Tab.ColorIndex = 10 Then ActiveSheet.Tab.ColorIndex = 2

iL = Cells(Rows.Count, 1).End(xlUp).Row - 2
Range("b4:b" & iL).Value = Range("h4:j" & iL).Value
Range("c4:g" & iL) = "" (тут надо что б очищало не только содержимое но и примечания)
Application.ScreenUpdating = True

GoTo Endd:
errHandle:
MsgBox "Ошибка"
Endd:

End Sub

Sniper1

Цитата:

Range("c4:g" & iL) = "" (тут надо что б очищало не только содержимое но и примечания)

Range("c4:g" & iL).ClearComments

А от чего зависит, что выпадающий список иногда выглядит с зафиксированной кнопкой для раскрытия, но чаще, по умолчанию, (при создании такого списка) она появляется только при нажатии на ячейку?
Как это можно настроить, чтобы было всегда? Спсб!

Sniper1
Ваш макрос можно немного упростить:

Код: Sub NewSheet()
Dim i As Long, shName As String: Application.ScreenUpdating = False
ActiveSheet.Copy after:=ActiveSheet: On Error Resume Next: i = 1
Do
shName = Format(Now, "DD.MM.YYYY") & "(" & i & ")"
Err.Clear: ActiveSheet.Name = shName: i = i + 1
Loop While Err <> 0
ActiveSheet.Tab.ColorIndex = Sheets(Sheets.Count - 1).Tab.ColorIndex + 1
If ActiveSheet.Tab.ColorIndex = 11 Then ActiveSheet.Tab.ColorIndex = 2
i = Cells(Rows.Count, 1).End(xlUp).Row - 2: Range("B4:B" & i) = Range("H4:J" & i)
Range("C4:G" & i) = "": Range("C4:G" & i).ClearComments
End Sub

Цитата:

Цитата:
Range("c4:g" & iL) = "" (тут надо что б очищало не только содержимое но и примечания)

Range("c4:g" & iL).ClearComments

LaCastet Спасибо!, то что надо было.



Цитата:

Sniper1
Ваш макрос можно немного упростить:

Код:
Sub NewSheet()
Dim i As Long, shName As String: Application.ScreenUpdating = False
ActiveSheet.Copy after:=ActiveSheet: On Error Resume Next: i = 1
Do
shName = Format(Now, "DD.MM.YYYY") & "(" & i & ")"
Err.Clear: ActiveSheet.Name = shName: i = i + 1
Loop While Err <> 0
ActiveSheet.Tab.ColorIndex = Sheets(Sheets.Count - 1).Tab.ColorIndex + 1
If ActiveSheet.Tab.ColorIndex = 11 Then ActiveSheet.Tab.ColorIndex = 2
i = Cells(Rows.Count, 1).End(xlUp).Row - 2: Range("B4:B" & i) = Range("H4:J" & i)
Range("C4:G" & i) = "": Range("C4:G" & i).ClearComments
End Sub

SAS888 мне очень понравился ваш вариант так как он обрабатывает очерёдность названия листов в должном порядке, но есть одно "но", вы скорей всего что то пропустили и имели в виду так:


Код: Sub NewSheet()
Dim i As Long, shName As String: Application.ScreenUpdating = False
ActiveSheet.Copy after:=ActiveSheet: On Error Resume Next: i = 1
Do
shName = Format(Now, "DD.MM.YYYY") & "(" & i & ")"
Err.Clear: ActiveSheet.Name = shName: i = i + 1
Loop While Err <> 0
ActiveSheet.Tab.ColorIndex = Sheets(Sheets.Count - 1).Tab.ColorIndex + 1
If ActiveSheet.Tab.ColorIndex = 11 Then ActiveSheet.Tab.ColorIndex = 2
i = Cells(Rows.Count, 1).End(xlUp).Row - 2: Range("B4:B" & i).Value = Range("H4:J" & i).Value
Range("C4:G" & i) = "": Range("C4:G" & i).ClearComments
End Sub

Sniper1

Цитата:

...вы скорей всего что то пропустили и имели в виду так...

Свойство .Value в VBA Excel является свойством по умолчанию. В данном случае его можно опустить. А что не так делает предложенный макрос?

Цитата:

А что не так делает предложенный макрос?

SAS888 без .Value почему то не копируется содержимое столба "H" в столб "B" при создание нового листа. И ещё при создание одного листа в день ему почему то все равно дается такое название 01.09.2010(1) когда надо 01.09.2010 а вот если создать ещё один лист в этот день то что б он был так 01.09.2010(1) и.т.д

Sniper1
Да. В данном случае происходит присваивание значений массиву. Поэтому, свойство .Value можно опустить только в одном случае (см. пример). Так же, по Вашему требованию, убран номер при первом копировании листа.

Код: Sub NewSheet()
Dim i As Long, shName As String: Application.ScreenUpdating = False
ActiveSheet.Copy after:=ActiveSheet: On Error Resume Next: i = 1
shName = Format(Now, "DD.MM.YYYY"): ActiveSheet.Name = shName
If Err <> 0 Then
Do
Err.Clear: ActiveSheet.Name = shName & "(" & i & ")": i = i + 1
Loop While Err <> 0
End If
ActiveSheet.Tab.ColorIndex = Sheets(Sheets.Count - 1).Tab.ColorIndex + 1
If ActiveSheet.Tab.ColorIndex = 11 Then ActiveSheet.Tab.ColorIndex = 2
i = Cells(Rows.Count, 1).End(xlUp).Row - 2: Range("B4:B" & i) = Range("H4:H" & i).Value
Range("C4:G" & i).ClearContents: Range("C4:G" & i).ClearComments
End Sub

Цитата:

Sniper1
Да. В данном случае происходит присваивание значений массиву. Поэтому, свойство .Value можно опустить только в одном случае (см. пример). Так же, по Вашему требованию, убран номер при первом копировании листа.

Код:
Sub NewSheet()
Dim i As Long, shName As String: Application.ScreenUpdating = False
ActiveSheet.Copy after:=ActiveSheet: On Error Resume Next: i = 1
shName = Format(Now, "DD.MM.YYYY"): ActiveSheet.Name = shName
If Err <> 0 Then
Do
Err.Clear: ActiveSheet.Name = shName & "(" & i & ")": i = i + 1
Loop While Err <> 0
End If
ActiveSheet.Tab.ColorIndex = Sheets(Sheets.Count - 1).Tab.ColorIndex + 1
If ActiveSheet.Tab.ColorIndex = 11 Then ActiveSheet.Tab.ColorIndex = 2
i = Cells(Rows.Count, 1).End(xlUp).Row - 2: Range("B4:B" & i) = Range("H4:H" & i).Value
Range("C4:G" & i).ClearContents: Range("C4:G" & i).ClearComments
End Sub

SAS888 огромное вам спасибо!, всё вроде супер.

А как можно подправить код, чтобы функция подсветки ячейки не убивала все форматирование на листе -

Private Sub Worksheet_SelectionChange(ByVal Target _
As Excel.Range)
Cells.Interior.ColorIndex = xlNone
With ActiveCell
.EntireRow.Interior.ColorIndex = 35
.EntireColumn.Interior.ColorIndex = 35
End With
End Sub

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

Frantishek
как вариант(криво, но все же), клонировать лист(достаточно только форматирования) и в конце вышеприведенного модуля подсасывать с клона на основной лист форматирование за исключением креста

Drazhar
Спасибо, как вариант пусть будет, но хотелось бы более изящного решения, т.к. табличка навороченная достаточно, клонировать неоптимально.

Frantishek
может, вместо изменения формата ячеек, рисовать два пересекающихся полупрозрачных прямоугольника?
или четыре чтобы не мешали нажимать на ячейки

smirnvlad
А как это в коде выглядит? Просто я сам не программер)

что-то вроде этого
[more]

Код:
Private Sub Worksheet_SelectionChange(ByVal Target _
As Excel.Range)

Dim s As Shape

Dim width As Integer
Dim color As Long
Dim trans As Single

For Each s In ActiveSheet.Shapes
If Left(s.Name, Len("selection-rect")) = "selection-rect" Then s.Delete
Next

width = 1
color = rgb(255, 0, 0)
trans = 0.8

With ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
ActiveCell.EntireRow.Left, _
ActiveCell.EntireRow.Top - width, _
ActiveCell.EntireRow.width, _
width * 2)
.Fill.ForeColor.rgb = color
.Fill.Transparency = trans
.Line.Visible = False
.Name = "selection-rect1"
End With

With ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
ActiveCell.EntireRow.Left, _
ActiveCell.EntireRow.Top + ActiveCell.EntireRow.Height - width, _
ActiveCell.EntireRow.width, _
width * 2)
.Fill.ForeColor.rgb = color
.Fill.Transparency = trans
.Line.Visible = False
.Name = "selection-rect2"
End With

With ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
ActiveCell.EntireColumn.Left - width, _
ActiveCell.EntireColumn.Top, _
width * 2, _
ActiveCell.EntireColumn.Height)
.Fill.ForeColor.rgb = color
.Fill.Transparency = trans
.Line.Visible = False
.Name = "selection-rect3"
End With

With ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
ActiveCell.EntireColumn.Left + ActiveCell.EntireColumn.width - width, _
ActiveCell.EntireColumn.Top, _
width * 2, _
ActiveCell.EntireColumn.Height)
.Fill.ForeColor.rgb = color
.Fill.Transparency = trans
.Line.Visible = False
.Name = "selection-rect4"
End With
End Sub

Ругается на вот это ("указанное значение выходит за допустимые пределы") -

With ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
ActiveCell.EntireColumn.Left - width, _
ActiveCell.EntireColumn.Top, _
width * 2, _
ActiveCell.EntireColumn.Height)