Как присвоить ячейке с данными число? - Microsoft Office Excel - Страница 3

vikttur · 01.04.2011, 19:06

Извлечение уникальных записей, посмотрите здесь

Pecnekm · 02.04.2011, 13:20

Цитата:

Сообщение от vikttur

Извлечение уникальных записей, посмотрите здесь

Спасибо. Но немножко не то, хотя тоже очень пригодилась информация.

Я нашел то, что мне нужно, только оно реализовано в макросе. Мне не принципиально, но он ошибку кидает:
"Compile error:
Ambiguous name detected: Workcheet_Change"
на эту строку ругается:
Private Sub Worksheet_Change(ByVal Target As Range)

Макрос на двух пробных документах работает, а на основном - нет.
Не могу понять почему.

Вот макрос целиком:

Код:

Option Explicit

Sub AutoUniqCount(Target As Range)
  
  Const TopCellSrc = "E3"   ' Первая ячейка списка
  Const TopCellDest = "R3"  ' Первая ячейка отчета
  
  Dim x, s$, Rng1 As Range, Rng2 As Range
  
  Set Rng1 = Range(TopCellSrc, Cells(Rows.Count, Left(TopCellSrc, 1)).End(xlUp))
  Set Rng2 = Range(TopCellDest, Cells(Rows.Count, Left(TopCellDest, 1)).End(xlUp))
  If Intersect(Target, Rng1.EntireColumn) Is Nothing And Intersect(Target, Rng2.Resize(, 2).EntireColumn) Is Nothing Then Exit Sub
  
  On Error GoTo exit_
  Application.EnableEvents = False
  
  ' Очистить отчет
  Rng2.Resize(, 2).ClearContents
  
  ' Создать новый отчет
  With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For Each x In Rng1.Value
      If VarType(x) = vbString Then
        s = Trim(x)
        ' Посчитать уникальные элементы в словаре
        If Len(s) Then .Item(s) = .Item(s) + 1
      End If
    Next
    ' Записать новый отчет
    If .Count Then
      Range(TopCellDest).Resize(.Count, 2).Value = WorksheetFunction.Transpose(Array(.Keys, .Items))
    End If
  End With

exit_:
  Application.EnableEvents = True
  
End Sub

' Событие активации листа
Private Sub Worksheet_Activate()
  AutoUniqCount Range(TopCellSrc)
End Sub

' Событие изменения
Private Sub Worksheet_Change(ByVal Target As Range)
  AutoUniqCount Target
End Sub

Помогите, пожалуйста, разобраться в чем проблема?

Hugo121 · 02.04.2011, 13:47

Private Sub Worksheet_Activate()
и
Private Sub Worksheet_Change(ByVal Target As Range)
должны быть в коде листа, и в одном экземпляре.

Pecnekm · 02.04.2011, 14:02

Цитата:

Сообщение от Hugo121

Private Sub Worksheet_Activate()
и
Private Sub Worksheet_Change(ByVal Target As Range)
должны быть в коде листа, и в одном экземпляре.

да у меня этих строк получается две. А как исправить ошибку? Строку же нельзя просто стереть? Чем её заменить можно, подскажите, пожалуйста?

Hugo121 · 02.04.2011, 14:10

Объединить оба кода в одной процедуре.
Т.е. в одной
Private Sub Worksheet_Change(ByVal Target As Range)
размещаете оба кода -
AutoUniqCount Target
и тот, что там был.
Чтоб всё прошло гладко - это нужно по месту смотреть.

Pecnekm · 02.04.2011, 14:27

Цитата:

Сообщение от Hugo121

Чтоб всё прошло гладко - это нужно по месту смотреть.

Можно еще разочек Вас побеспокоить и всё ?

Посмотрите, пожалуйста, вот целиком все макросы:

Код:

Private Sub ComboBox1_Change()
    Application.EnableEvents = False
    ActiveCell.Value = Me.ComboBox1.Value
    ' ActiveCell.Offset(1).Select
    'HideCombo
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, [e3:e300]) Is Nothing Or Target.Cells.Count > 1 Then HideCombo: Exit Sub
    Application.EnableEvents = False
    Me.ComboBox1.Top = Target.Top
    Me.ComboBox1.Left = Target.Left
    Me.ComboBox1.Width = Target.Width + 14
    Me.ComboBox1.Height = Target.Height
    FillCombo
    Application.EnableEvents = True
End Sub

Sub FillCombo()
    Me.ComboBox1.Clear
   With Sheets("Base")
        For i = 3 To .Cells(Rows.Count, "t").End(xlUp).Row
            ComboBox1.AddItem .Cells(i, 20)
        Next
    End With
    Me.ComboBox1.Value = ActiveCell.Value
    Me.ComboBox1.Font.Size = 8
    Me.ComboBox1.ListRows = 30
End Sub

Sub HideCombo()
    Me.ComboBox1.Top = 0
    Me.ComboBox1.Left = 0
    Me.ComboBox1.Width = 0
    Me.ComboBox1.Height = 0
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
       If Target.Cells.Count > 1 Then Exit Sub
          If Not Intersect(Target, Range("b3:b300")) Is Nothing Then
             With Target(1, 0)
                .Value = Now
                                                
                                                End With
         End If
    End Sub


Option Explicit

Sub AutoUniqCount(Target As Range)
  
  Const TopCellSrc = "E3"   ' Первая ячейка списка
  Const TopCellDest = "R3"  ' Первая ячейка отчета
  
  Dim x, s$, Rng1 As Range, Rng2 As Range
  
  Set Rng1 = Range(TopCellSrc, Cells(Rows.Count, Left(TopCellSrc, 1)).End(xlUp))
  Set Rng2 = Range(TopCellDest, Cells(Rows.Count, Left(TopCellDest, 1)).End(xlUp))
  If Intersect(Target, Rng1.EntireColumn) Is Nothing And Intersect(Target, Rng2.Resize(, 2).EntireColumn) Is Nothing Then Exit Sub
  
  On Error GoTo exit_
  Application.EnableEvents = False
  
  ' Очистить отчет
  Rng2.Resize(, 2).ClearContents
  
  ' Создать новый отчет
  With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For Each x In Rng1.Value
      If VarType(x) = vbString Then
        s = Trim(x)
        ' Посчитать уникальные элементы в словаре
        If Len(s) Then .Item(s) = .Item(s) + 1
      End If
    Next
    ' Записать новый отчет
    If .Count Then
      Range(TopCellDest).Resize(.Count, 2).Value = WorksheetFunction.Transpose(Array(.Keys, .Items))
    End If
  End With

exit_:
  Application.EnableEvents = True
  
End Sub

' Событие активации листа
Private Sub Worksheet_Activate()
  AutoUniqCount Range(TopCellSrc)
End Sub

' Событие изменения
Private Sub Worksheet_Change(ByVal Target As Range)
  AutoUniqCount Target
End Sub

Hugo121 · 02.04.2011, 15:04

Нет, я комбо рисовать не буду. Давйте в файле.
А так предварительно -

Private Sub Worksheet_Change(ByVal Target As Range)
AutoUniqCount Target
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("b3:b300")) Is Nothing Then
With Target(1, 0)
.Value = Now

End With
End If

End Sub

Только ещё вероятно Application.EnableEvents = False нужно добавить.

Pecnekm · 02.04.2011, 15:30

Попробовал, не работает, но и ошибку не кидает...

Добавил файлик во вложения, посмотрите пожалуйста, что не так.

Hugo121 · 02.04.2011, 17:33

Ну первопричина - это то, что на изменение комбо не происходит событие Worksheet_Change

Потому что:

Код:

Private Sub ComboBox1_Change()
    Application.EnableEvents = False ' отключаем события
    ActiveCell.Value = Me.ComboBox1.Value
    ' ActiveCell.Offset(1).Select
    'HideCombo
    Application.EnableEvents = True  ' включаем события
End Sub

Hugo121 · 02.04.2011, 17:48

Замените весь свой код модуля листа на этот (лишнее не стирал, только закомментировал):

Код:

Private Sub ComboBox1_Change()
'    Application.EnableEvents = False
    ActiveCell.Value = Me.ComboBox1.Value
    ' ActiveCell.Offset(1).Select
    'HideCombo
    '    Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, [e3:e300]) Is Nothing Or Target.Cells.Count > 1 Then HideCombo: Exit Sub
    Application.EnableEvents = False
    Me.ComboBox1.Top = Target.Top
    Me.ComboBox1.Left = Target.Left
    Me.ComboBox1.Width = Target.Width + 14
    Me.ComboBox1.Height = Target.Height
    FillCombo
    Application.EnableEvents = True
End Sub

Sub FillCombo()
    Me.ComboBox1.Clear
    With Sheets("Base")
        For i = 3 To .Cells(Rows.Count, "t").End(xlUp).Row
            ComboBox1.AddItem .Cells(i, 20)
        Next
    End With
    Me.ComboBox1.Value = ActiveCell.Value
    Me.ComboBox1.Font.Size = 8
    Me.ComboBox1.ListRows = 30
End Sub

Sub HideCombo()
    Me.ComboBox1.Top = 0
    Me.ComboBox1.Left = 0
    Me.ComboBox1.Width = 0
    Me.ComboBox1.Height = 0
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("b3:b300")) Is Nothing Then
        With Target(1, 0)
            .Value = Now
        End With
    End If
    If Not Intersect(Target, Range("E3:E300")) Is Nothing Then
    AutoUniqCount Target
    End If

End Sub


Sub AutoUniqCount(Target As Range)

    Const TopCellSrc = "E3"   ' Первая ячейка списка
    Const TopCellDest = "R3"  ' Первая ячейка отчета

    Dim x, s$, Rng1 As Range, Rng2 As Range

    Set Rng1 = Range(TopCellSrc, Cells(Rows.Count, Left(TopCellSrc, 1)).End(xlUp))
    Set Rng2 = Range(TopCellDest, Cells(Rows.Count, Left(TopCellDest, 1)).End(xlUp))
    If Intersect(Target, Rng1.EntireColumn) Is Nothing And Intersect(Target, Rng2.Resize(, 2).EntireColumn) Is Nothing Then Exit Sub

    On Error GoTo exit_
    Application.EnableEvents = False

    ' Очистить отчет
    Rng2.Resize(, 2).ClearContents

    ' Создать новый отчет
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For Each x In Rng1.Value
            If VarType(x) = vbString Then
                s = Trim(x)
                ' Посчитать уникальные элементы в словаре
                If Len(s) Then .Item(s) = .Item(s) + 1
            End If
        Next
        ' Записать новый отчет
        If .Count Then
            Range(TopCellDest).Resize(.Count, 2).Value = WorksheetFunction.Transpose(Array(.Keys, .Items))
        End If
    End With

exit_:
    Application.EnableEvents = True

End Sub

' Событие активации листа
Private Sub Worksheet_Activate()
    AutoUniqCount Range("E3") 'TopCellSrc)
End Sub


'' Событие изменения
'Private Sub Worksheet_Change(ByVal Target As Range)
'  AutoUniqCount Target
'End Sub

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

Так например - попробуйте эти два кода заменить на:

Код:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim iLastrow As Long
iLastrow = Cells(Rows.Count, 2).End(xlUp).Row

    If Intersect(Target, Range("e3:e" & iLastrow)) Is Nothing Or Target.Cells.Count > 1 Then HideCombo: Exit Sub
    Application.EnableEvents = False
    Me.ComboBox1.Top = Target.Top
    Me.ComboBox1.Left = Target.Left
    Me.ComboBox1.Width = Target.Width + 14
    Me.ComboBox1.Height = Target.Height
    FillCombo
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim iLastrow As Long
    If Target.Cells.Count > 1 Then Exit Sub
   iLastrow = Cells(Rows.Count, 2).End(xlUp).Row
 
    If Not Intersect(Target, Range("b3:b" & iLastrow)) Is Nothing Then
        With Target(1, 0)
            .Value = Now
        End With
    End If
    If Not Intersect(Target, Range("E3:E" & iLastrow)) Is Nothing Then
    AutoUniqCount Target
    End If

End Sub

Бонус - так пока не будет заполнено имя/фамилия, не будет доступен выбор товара.

02.04.2011, 13:47	#23
Hugo121 Старожил Регистрация: 11.05.2010 Сообщений: 5,166	Private Sub Worksheet_Activate() и Private Sub Worksheet_Change(ByVal Target As Range) должны быть в коде листа, и в одном экземпляре. webmoney: E265281470651 Z422237915069 R418926282008

02.04.2011, 14:10	#25
Hugo121 Старожил Регистрация: 11.05.2010 Сообщений: 5,166	Объединить оба кода в одной процедуре. Т.е. в одной Private Sub Worksheet_Change(ByVal Target As Range) размещаете оба кода - AutoUniqCount Target и тот, что там был. Чтоб всё прошло гладко - это нужно по месту смотреть. webmoney: E265281470651 Z422237915069 R418926282008

02.04.2011, 15:04	#27
Hugo121 Старожил Регистрация: 11.05.2010 Сообщений: 5,166	Нет, я комбо рисовать не буду. Давйте в файле. А так предварительно - Private Sub Worksheet_Change(ByVal Target As Range) AutoUniqCount Target If Target.Cells.Count > 1 Then Exit Sub If Not Intersect(Target, Range("b3:b300")) Is Nothing Then With Target(1, 0) .Value = Now End With End If End Sub Только ещё вероятно Application.EnableEvents = False нужно добавить. webmoney: E265281470651 Z422237915069 R418926282008

02.04.2011, 17:33	#29
Hugo121 Старожил Регистрация: 11.05.2010 Сообщений: 5,166	Ну первопричина - это то, что на изменение комбо не происходит событие Worksheet_Change Потому что: Код: `Private Sub ComboBox1_Change() Application.EnableEvents = False ' отключаем события ActiveCell.Value = Me.ComboBox1.Value ' ActiveCell.Offset(1).Select 'HideCombo Application.EnableEvents = True ' включаем события End Sub` webmoney: E265281470651 Z422237915069 R418926282008 Последний раз редактировалось Hugo121; 02.04.2011 в 17:35.

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Как присвоить одной ячейке несколько значений?	Хорошая Девочка	Microsoft Office Excel	2	10.10.2010 20:58
Присвоить ячейке StringGrid переменную	DimOn4Ik	Помощь студентам	6	19.01.2010 16:27
присвоить значение ячейки с курсором ячейке А1	Temnota	Microsoft Office Excel	5	24.11.2009 21:10
Как присвоить ячейке имя?	Maxx	Microsoft Office Excel	2	01.11.2008 11:30
как присвоить значение ячейки R1C1 из 1.xls, допустим какой-нибудь любой ячейке из 2.xls ?	diabloskrk	Microsoft Office Excel	3	08.10.2007 12:27

01.04.2011, 19:06	#21
vikttur Участник клуба Регистрация: 16.05.2010 Сообщений: 1,249	Извлечение уникальных записей, посмотрите здесь