Страницы: 1
RSS
"цветная" строка в поле зрения
 
Можно ли такое сделать? Вопрос во вложении.
 
можно
Bite my shiny metal ass!      
 
{quote}{login=Лузер™}{date=04.11.2009 06:43}{thema=}{post}можно{/post}{/quote}  
Спасибо. То что нужно. Но в примере я взяла просто список.А у меня есть реальная база где много всего. И там уже же есть некот. макросы. Прописываю этот пишет ошибку. Как исправиить не знаю. В этом вообще не сильна. Посмотрите пжл. Явно надо где подправить в начале. У меня вместо яч. "F6" яч."Q15" а вместо столбца "А" столб."J".
 
Ира, вот небольшой фрагмент из правил "старайтесь сохранить структуру, расположение таблиц, имена листов - аналогично оригиналу." Вы их читали?
 
Private Sub Worksheet_Change(ByVal Target As Range)  
   If Target.Address = [f6].Address Then
       On Error Resume Next: Dim к As Long  
       r = [a:a].Find(Target, , , xlWhole).Row
       If r = 0 Then r = 9  
       ActiveWindow.ScrollRow = r  
       On Error GoTo 0  
   End If  
 
   ' далее ваш код  
End Sub  
 
Пример файла:  http://excelvba.ru/XL_Files/Sample__04-11-2009__21-38-27.zip  
 
PS: Что за дурацкая идея выкладывать код в виде скриншота?
 
{quote}{login=EducatedFool}{date=04.11.2009 07:34}{thema=}{post} Что за дурацкая идея выкладывать код в виде скриншота?{/post}{/quote}Ну вдруг кто не знает как код посмотреть в книге, а тут - вот он :D
Bite my shiny metal ass!      
 
Или скопировать захочет. А не тут-то было!
 
Все равно не могу (не знаю) как подправить этот макрос.  
чтобы он работал с уже имеющ.двумя.  
Один отвечает за то чтобы в соседней ячейке проставлялась дата.другой за заполнение бланка данными из этой базы.  
Подскажите как подправить этот третий Чтоб работало.  
Вот все что в "исходном тексте".СПАСИБО  
 
Private Sub CommandButton1_Click()  
 
End Sub  
 
Private Sub Worksheet_Change(ByVal Target As Range)  
  If Target.Cells.Count > 1 Then Exit Sub  
     If Not Intersect(Target, Range("C19:C6000, E19:E6000, J19:J6000, AH19:AH6000")) Is Nothing Then  
        With Target(1, 2)  
           If Target <> "" Then  
              .Value = Now  
           Else  
              .Value = ""  
           End If  
        End With  
  End If  
'''''''''''''''''  
Dim r As Long  
Dim str As String  
If Target.Count > 1 Then Exit Sub  
  If Target.Column = 1 Then  
     str = Target.Value  
     Application.EnableEvents = False  
     r = Cells(Rows.Count, 2).End(xlUp).Row  
     Range("A2:A" & r).ClearContents  
     Target.Value = str  
  End If  
Application.EnableEvents = True  
End Sub  
 
Private Sub Worksheet_Change(ByVal Target As Range)  
If Target.Address <> Range("Q15").Address Then Exit Sub  
Set rng = Range("J:J").Find(Target.Value, LookAt:=xlWhole)  
If rng Is Nothing Then Exit Sub  
Application.Goto rng.Address(ReferenceStyle:=xlR1C1), True  
End Sub
 
Замените ВЕСЬ свой код вот этим:  
 
 
Private Sub Worksheet_Change(ByVal Target As Range)  
   If Target.Address = [q15].Address Then
       On Error Resume Next: Dim r As Long  
       r = [j:j].Find(Target, , , xlWhole).Row
       If r = 0 Then r = 9  
       ActiveWindow.ScrollRow = r  
       On Error GoTo 0  
   End If  
 
   If Target.Cells.Count > 1 Then Exit Sub  
   If Not Intersect(Target, Range("C19:C6000, E19:E6000, J19:J6000, AH19:AH6000")) Is Nothing Then  
       Target(1, 2).Value = IIf(Len(Target), Now, "")  
   End If  
 
   Dim r As Long, s As String  
   If Target.Column = 1 Then  
       s = Target.Value  
       Application.EnableEvents = False  
       r = Cells(Rows.Count, 2).End(xlUp).Row  
       Range("A2:A" & r).ClearContents  
       Target.Value = s  
       Application.EnableEvents = True  
   End If  
End Sub
 
{quote}{login=EducatedFool}{date=05.11.2009 08:32}{thema=}{post}Замените ВЕСЬ свой код вот этим:  
Заменила. Не работает. Ошибки.  
Т.е.не работ ни один из 3-х макр. Один из них (тот что на заполнение)некорректно.    
Как исправить чтоб работало. ?
 
{quote}{login=Ира}{date=05.11.2009 09:13}{thema=Re: }{post}{quote}  
Заменила. Не работает. Ошибки.  
Т.е.не работ ни один из 3-х макр. {/post}{/quote}  
 
Из каких ещё 3-х макросов?  
 
Должен быть один макрос Private Sub Worksheet_Change(ByVal Target As Range)  
 
Выкладывайте файл, если хотите готовое решение.
 
Кажется заработало:  
Но я исправила вот здесь Dim r As Long на Dim str As Long    
 
Т.Е вот в этой части кода:  
Dim str As Long, s As String  
If Target.Column = 1 Then  
s = Target.Value  
Application.EnableEvents = False  
r = Cells(Rows.Count, 2).End(xlUp).Row  
Range("A2:A" & r).ClearContents  
Target.Value = s  
Application.EnableEvents = True  
End If  
End Sub  
 
Честно не знаю что это означает str и r. Но работает кажется правильно.  
Спасибо
 
{quote}{login=The_Prist}{date=05.11.2009 11:28}{thema=}{post}А если так?  
Dim r As Long, s As String  
If Target.Column = 1 Then  
s = Target.Value  
Application.EnableEvents = False  
r = Cells(Rows.Count, 1).End(xlUp).Row  
Range("A2:A" & r).ClearContents  
Target.Value = s  
Application.EnableEvents = True  
End If  
End Sub{/post}{/quote}  
 
Я же говорю что так не работает
 
{quote}{login=The_Prist}{date=05.11.2009 01:17}{thema=Re: Re: }{post}{quote}{login=Ира}{date=05.11.2009 12:42}{thema=Re: }{post}Я же говорю что так не работает{/post}{/quote}А я не вижу смысла в переменной str. Где она у Вас используется? И в чем конкретно заключается неработа предыдущего кода?{/post}{/quote}  
Честно я вообще не умею читать коды, и не знаю что означают переменные. Могу только сориентироваться с названием ячеек в них и все.  
Файл у меня тяжеловат. Могу скинуть Вам на e-mail посмотрите и увидите как не работает.
Страницы: 1
Читают тему
Наверх
Loading...