Вставка строки - Мир MS Excel

Регистрация

Напомнить пароль

= Мир MS Excel/Вставка строки - Мир MS Excel

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Вставка строки

Вставка строки

Дата: Четверг, 02.02.2012, 07:00 | Сообщение № 1

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 136

Репутация: 0 ±

Замечаний: 0% ±

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

К сообщению приложен файл: 2091244.xls (26.5 Kb)

Ответить

Дата: Четверг, 02.02.2012, 10:30 | Сообщение № 2

Группа: Друзья

Ранг: Ветеран

Сообщений: 1068

Репутация: 560 ±

Замечаний: 0% ±

XL 2016

Критерий новой строки? Наименование? ...+Страна? ...+...+Цена?

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

Ответить

Дата: Четверг, 02.02.2012, 10:39 | Сообщение № 3

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 136

Репутация: 0 ±

Замечаний: 0% ±

Если я добавляю новую строку,то вся строка должна вставляться в базу.Бывает и редактирование одной ячейки.

Ответить

Дата: Четверг, 02.02.2012, 10:48 | Сообщение № 4

Группа: Друзья

Ранг: Ветеран

Сообщений: 1068

Репутация: 560 ±

Замечаний: 0% ±

XL 2016

т.е. ты вставляешь откуда-то целую строку?
редактирование на листе "ввод" должно менять "базу"?
про критерий новой строки я не услышал.

Ответить

Дата: Четверг, 02.02.2012, 11:40 | Сообщение № 5

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 136

Репутация: 0 ±

Замечаний: 0% ±

Саня.Например ищу шины (отмечаны желтым), а в базе нет, тогда встаю на похожей строке Shift+пробел и Ctrl+D , потом редактирую ячейки как мне надо

Ответить

Дата: Четверг, 02.02.2012, 13:04 | Сообщение № 6

Группа: Друзья

Ранг: Ветеран

Сообщений: 1068

Репутация: 560 ±

Замечаний: 0% ±

XL 2016

проверяет новое ли название (нет в базе), заполнены ли все поля (страна, цена, ...), при выполнении всех условий добавляет в базу новую строку:
[vba]

Код

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
     If Target.Rows.Count > 1 Then Exit Sub

     If Intersect(Target, Columns("B:G")) Is Nothing Then Exit Sub
     If Intersect(Target, Columns("B:G")).Address <> Target.Address Then Exit Sub

     Dim r As Integer
     r = Target.Row

     Dim sName As String
     sName = Range("C" & r)
     If IsNewName(sName) Then
         If IsFilledAllFields(r) Then
             AddToBase Range("B" & r).Resize(, 6)
         End If

     Else
         ' если НЕ новая позиция
     End If
End Sub

Function IsNewName(sName As String) As Boolean
     IsNewName = (Sheets("база").Columns("D:D").Find(sName) Is Nothing)
End Function

Function IsFilledAllFields(r As Integer) As Boolean
     IsFilledAllFields = False
     Dim c As Range
     For Each c In Sheets("ввод").Range("B" & r).Resize(, 6)
         If Len(c.Value) = 0 Then Exit Function
     Next c
     IsFilledAllFields = True
End Function

Sub AddToBase(rng As Range)
     With Sheets("база")
         Dim lr As Integer
         lr = .Range("B2").End(xlDown).Row

         Dim nn As Integer
         nn = CInt(.Range("B" & lr))

         .Range("B" & lr + 1) = nn + 1
         .Range("C" & lr + 1).Resize(, 6).Value = rng.Value
     End With
End Sub

[/vba]

К сообщению приложен файл: 0685167.xls (54.5 Kb)

Ответить

Дата: Пятница, 03.02.2012, 04:17 | Сообщение № 7

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 136

Репутация: 0 ±

Замечаний: 0% ±

Саня. Ошибку дает,когда я вставляю с другим кодом.
Вот

К сообщению приложен файл: _02-02-12.xls (41.5 Kb)

Ответить

Дата: Пятница, 03.02.2012, 10:30 | Сообщение № 8

Группа: Друзья

Ранг: Ветеран

Сообщений: 1068

Репутация: 560 ±

Замечаний: 0% ±

XL 2016

ты вообще с VBA никак?
там два одинаковых обработчика событий было...
правой кнопкой мыши по ярлыку листа "ввод" - исходный текст - Ctrl+A - Del - вставишь туды это:
[vba]

Code

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
      If Target.Address = [m1].Address Then
          Application.EnableEvents = False
          Dim rng As Range
          Me.Columns("B:H").ClearContents
          With Sheets("база")
              Set rng = .Range(.[c2], .Cells(.[c2].End(xlDown).Row, .[c2].End(xlToRight).Column))
              .AutoFilterMode = False
              rng.AutoFilter Field:=2, Criteria1:="=*" & Target.Value & "*"
              rng.SpecialCells(12).Copy Me.[b2]
              .AutoFilterMode = False
          End With
          Application.EnableEvents = True
      End If
      '---------------------------------------------------------------------------
      '---------------------------------------------------------------------------

      If Target.Rows.Count > 1 Then Exit Sub

      If Intersect(Target, Columns("B:G")) Is Nothing Then Exit Sub
      If Intersect(Target, Columns("B:G")).Address <> Target.Address Then Exit Sub

      Dim r As Integer
      r = Target.Row

      Dim sName As String
      sName = Range("C" & r)
      If IsNewName(sName) Then
          If IsFilledAllFields(r) Then
              AddToBase Range("B" & r).Resize(, 6)
          End If

      Else
          ' если НЕ новая позиция
      End If
End Sub

Function IsNewName(sName As String) As Boolean
      IsNewName = (Sheets("база").Columns("D:D").Find(sName) Is Nothing)
End Function

Function IsFilledAllFields(r As Integer) As Boolean
      IsFilledAllFields = False
      Dim c As Range
      For Each c In Sheets("ввод").Range("B" & r).Resize(, 6)
          If Len(c.Value) = 0 Then Exit Function
      Next c
      IsFilledAllFields = True
End Function

Sub AddToBase(rng As Range)
      With Sheets("база")
          Dim lr As Integer
          lr = .Range("B2").End(xlDown).Row

          Dim nn As Integer
          nn = CInt(.Range("B" & lr))

          .Range("B" & lr + 1) = nn + 1
          .Range("C" & lr + 1).Resize(, 6).Value = rng.Value
      End With
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
       Me.Range(Me.Cells(Target.Row, 2), Me.Cells(Target.Row, 7)).Copy _
      Sheets("таблица").[b65536].End(xlUp).Offset(1)
Cancel = True
End Sub

[/vba]

ты вообще с VBA никак?
там два одинаковых обработчика событий было...
правой кнопкой мыши по ярлыку листа "ввод" - исходный текст - Ctrl+A - Del - вставишь туды это:
[vba]

Code

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
      If Target.Address = [m1].Address Then
          Application.EnableEvents = False
          Dim rng As Range
          Me.Columns("B:H").ClearContents
          With Sheets("база")
              Set rng = .Range(.[c2], .Cells(.[c2].End(xlDown).Row, .[c2].End(xlToRight).Column))
              .AutoFilterMode = False
              rng.AutoFilter Field:=2, Criteria1:="=*" & Target.Value & "*"
              rng.SpecialCells(12).Copy Me.[b2]
              .AutoFilterMode = False
          End With
          Application.EnableEvents = True
      End If
      '---------------------------------------------------------------------------
      '---------------------------------------------------------------------------

      If Target.Rows.Count > 1 Then Exit Sub

      If Intersect(Target, Columns("B:G")) Is Nothing Then Exit Sub
      If Intersect(Target, Columns("B:G")).Address <> Target.Address Then Exit Sub

      Dim r As Integer
      r = Target.Row

      Dim sName As String
      sName = Range("C" & r)
      If IsNewName(sName) Then
          If IsFilledAllFields(r) Then
              AddToBase Range("B" & r).Resize(, 6)
          End If

      Else
          ' если НЕ новая позиция
      End If
End Sub

Function IsNewName(sName As String) As Boolean
      IsNewName = (Sheets("база").Columns("D:D").Find(sName) Is Nothing)
End Function

Function IsFilledAllFields(r As Integer) As Boolean
      IsFilledAllFields = False
      Dim c As Range
      For Each c In Sheets("ввод").Range("B" & r).Resize(, 6)
          If Len(c.Value) = 0 Then Exit Function
      Next c
      IsFilledAllFields = True
End Function

Sub AddToBase(rng As Range)
      With Sheets("база")
          Dim lr As Integer
          lr = .Range("B2").End(xlDown).Row

          Dim nn As Integer
          nn = CInt(.Range("B" & lr))

          .Range("B" & lr + 1) = nn + 1
          .Range("C" & lr + 1).Resize(, 6).Value = rng.Value
      End With
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
       Me.Range(Me.Cells(Target.Row, 2), Me.Cells(Target.Row, 7)).Copy _
      Sheets("таблица").[b65536].End(xlUp).Offset(1)
Cancel = True
End Sub

Ответить

Сообщениеты вообще с VBA никак?
там два одинаковых обработчика событий было...
правой кнопкой мыши по ярлыку листа "ввод" - исходный текст - Ctrl+A - Del - вставишь туды это:
[vba]

Code

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
      If Target.Address = [m1].Address Then
          Application.EnableEvents = False
          Dim rng As Range
          Me.Columns("B:H").ClearContents
          With Sheets("база")
              Set rng = .Range(.[c2], .Cells(.[c2].End(xlDown).Row, .[c2].End(xlToRight).Column))
              .AutoFilterMode = False
              rng.AutoFilter Field:=2, Criteria1:="=*" & Target.Value & "*"
              rng.SpecialCells(12).Copy Me.[b2]
              .AutoFilterMode = False
          End With
          Application.EnableEvents = True
      End If
      '---------------------------------------------------------------------------
      '---------------------------------------------------------------------------

      If Target.Rows.Count > 1 Then Exit Sub

      If Intersect(Target, Columns("B:G")) Is Nothing Then Exit Sub
      If Intersect(Target, Columns("B:G")).Address <> Target.Address Then Exit Sub

      Dim r As Integer
      r = Target.Row

      Dim sName As String
      sName = Range("C" & r)
      If IsNewName(sName) Then
          If IsFilledAllFields(r) Then
              AddToBase Range("B" & r).Resize(, 6)
          End If

      Else
          ' если НЕ новая позиция
      End If
End Sub

Function IsNewName(sName As String) As Boolean
      IsNewName = (Sheets("база").Columns("D:D").Find(sName) Is Nothing)
End Function

Function IsFilledAllFields(r As Integer) As Boolean
      IsFilledAllFields = False
      Dim c As Range
      For Each c In Sheets("ввод").Range("B" & r).Resize(, 6)
          If Len(c.Value) = 0 Then Exit Function
      Next c
      IsFilledAllFields = True
End Function

Sub AddToBase(rng As Range)
      With Sheets("база")
          Dim lr As Integer
          lr = .Range("B2").End(xlDown).Row

          Dim nn As Integer
          nn = CInt(.Range("B" & lr))

          .Range("B" & lr + 1) = nn + 1
          .Range("C" & lr + 1).Resize(, 6).Value = rng.Value
      End With
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
       Me.Range(Me.Cells(Target.Row, 2), Me.Cells(Target.Row, 7)).Copy _
      Sheets("таблица").[b65536].End(xlUp).Offset(1)
Cancel = True
End Sub

[/vba]

Автор - Саня
Дата добавления - 03.02.2012 в 10:30

Дата: Пятница, 03.02.2012, 14:11 | Сообщение № 9

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 136

Репутация: 0 ±

Замечаний: 0% ±

Саня. Большое спасибо. VBA я не знаю

Ответить

Дата: Вторник, 07.02.2012, 17:27 | Сообщение № 10

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 136

Репутация: 0 ±

Замечаний: 0% ±

Уважаемые форумчане. Саня мне помог с кодом.Но теперь когда я полностью сделал базу она дает ошибку (база состоит из 40 000 наименований) Прошу Вашей помощи. Спасибо

К сообщению приложен файл: 7457184.jpg (7.8 Kb)

Ответить

Дата: Вторник, 07.02.2012, 17:29 | Сообщение № 11

Группа: Друзья

Ранг: Ветеран

Сообщений: 1068

Репутация: 560 ±

Замечаний: 0% ±

XL 2016

найди в коде все слова Integer и замени их на Long

Ответить

Дата: Вторник, 07.02.2012, 18:12 | Сообщение № 12

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 136

Репутация: 0 ±

Замечаний: 0% ±

Саня. Теперь пишет так

К сообщению приложен файл: 6808676.rar (58.3 Kb)

Ответить

Дата: Вторник, 07.02.2012, 18:37 | Сообщение № 13

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 136

Репутация: 0 ±

Замечаний: 0% ±

Что-то не получилось с архивом

К сообщению приложен файл: 5036943.jpg (34.5 Kb)

Ответить

Дата: Вторник, 07.02.2012, 19:58 | Сообщение № 14

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 136

Репутация: 0 ±

Замечаний: 0% ±

Ребята помогите

Ответить

Дата: Вторник, 07.02.2012, 20:16 | Сообщение № 15

Группа: Друзья

Ранг: Ветеран

Сообщений: 1068

Репутация: 560 ±

Замечаний: 0% ±

XL 2016

у тебя на рисунке виден фрагмент

Code

dim lr as integer

а я тебе написал - замени integer на long, где здравый смысл? deal

deal

сам себе помоги сначала

Ответить

Дата: Среда, 08.02.2012, 04:38 | Сообщение № 16

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 136

Репутация: 0 ±

Замечаний: 0% ±

[vba]

Code

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = [m1].Address Then
Application.EnableEvents = False
Dim rng As Range
Me.Columns("B:H").ClearContents
With Sheets("база")
Set rng = .Range(.[c2], .Cells(.[c2].End(xlDown).Row, .[c2].End(xlToRight).Column))
.AutoFilterMode = False
rng.AutoFilter Field:=2, Criteria1:="=*" & Target.Value & "*"
rng.SpecialCells(12).Copy Me.[b2]
.AutoFilterMode = False
End With
Application.EnableEvents = True
End If
'---------------------------------------------------------------------------
'---------------------------------------------------------------------------

If Target.Rows.Count > 1 Then Exit Sub

If Intersect(Target, Columns("B:G")) Is Nothing Then Exit Sub
If Intersect(Target, Columns("B:G")).Address <> Target.Address Then Exit Sub

Dim r As Long
r = Target.Row

Dim sName As String
sName = Range("C" & r)
If IsNewName(sName) Then
If IsFilledAllFields(r) Then
AddToBase Range("B" & r).Resize(, 6)
End If

Else
' если НЕ новая позиция
End If
End Sub

Function IsNewName(sName As String) As Boolean
IsNewName = (Sheets("база").Columns("D:D").Find(sName) Is Nothing)
End Function

Function IsFilledAllFields(r As Long) As Boolean
IsFilledAllFields = False
Dim c As Range
For Each c In Sheets("ввод").Range("B" & r).Resize(, 6)
If Len(c.Value) = 0 Then Exit Function
Next c
IsFilledAllFields = True
End Function

Sub AddToBase(rng As Range)
With Sheets("база")
Dim lr As Long
lr = .Range("B2").End(xlDown).Row

Dim nn As Long
nn = CInt(.Range("B" & lr))

.Range("B" & lr + 1) = nn + 1
.Range("C" & lr + 1).Resize(, 6).Value = rng.Value
End With
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Me.Range(Me.Cells(Target.Row, 2), Me.Cells(Target.Row, 7)).Copy _
Sheets("таблица").[b65536].End(xlUp).Offset(1)
Cancel = True
End Sub

[/vba]

Долго искал, не могу найти. Помоги Саня

[vba]

Code

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = [m1].Address Then
Application.EnableEvents = False
Dim rng As Range
Me.Columns("B:H").ClearContents
With Sheets("база")
Set rng = .Range(.[c2], .Cells(.[c2].End(xlDown).Row, .[c2].End(xlToRight).Column))
.AutoFilterMode = False
rng.AutoFilter Field:=2, Criteria1:="=*" & Target.Value & "*"
rng.SpecialCells(12).Copy Me.[b2]
.AutoFilterMode = False
End With
Application.EnableEvents = True
End If
'---------------------------------------------------------------------------
'---------------------------------------------------------------------------

If Target.Rows.Count > 1 Then Exit Sub

If Intersect(Target, Columns("B:G")) Is Nothing Then Exit Sub
If Intersect(Target, Columns("B:G")).Address <> Target.Address Then Exit Sub

Dim r As Long
r = Target.Row

Dim sName As String
sName = Range("C" & r)
If IsNewName(sName) Then
If IsFilledAllFields(r) Then
AddToBase Range("B" & r).Resize(, 6)
End If

Else
' если НЕ новая позиция
End If
End Sub

Function IsNewName(sName As String) As Boolean
IsNewName = (Sheets("база").Columns("D:D").Find(sName) Is Nothing)
End Function

Function IsFilledAllFields(r As Long) As Boolean
IsFilledAllFields = False
Dim c As Range
For Each c In Sheets("ввод").Range("B" & r).Resize(, 6)
If Len(c.Value) = 0 Then Exit Function
Next c
IsFilledAllFields = True
End Function

Sub AddToBase(rng As Range)
With Sheets("база")
Dim lr As Long
lr = .Range("B2").End(xlDown).Row

Dim nn As Long
nn = CInt(.Range("B" & lr))

.Range("B" & lr + 1) = nn + 1
.Range("C" & lr + 1).Resize(, 6).Value = rng.Value
End With
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Me.Range(Me.Cells(Target.Row, 2), Me.Cells(Target.Row, 7)).Copy _
Sheets("таблица").[b65536].End(xlUp).Offset(1)
Cancel = True
End Sub

[/vba]

Долго искал, не могу найти. Помоги Саняrow

Ответить

Сообщение[vba]

Code

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = [m1].Address Then
Application.EnableEvents = False
Dim rng As Range
Me.Columns("B:H").ClearContents
With Sheets("база")
Set rng = .Range(.[c2], .Cells(.[c2].End(xlDown).Row, .[c2].End(xlToRight).Column))
.AutoFilterMode = False
rng.AutoFilter Field:=2, Criteria1:="=*" & Target.Value & "*"
rng.SpecialCells(12).Copy Me.[b2]
.AutoFilterMode = False
End With
Application.EnableEvents = True
End If
'---------------------------------------------------------------------------
'---------------------------------------------------------------------------

If Target.Rows.Count > 1 Then Exit Sub

If Intersect(Target, Columns("B:G")) Is Nothing Then Exit Sub
If Intersect(Target, Columns("B:G")).Address <> Target.Address Then Exit Sub

Dim r As Long
r = Target.Row

Dim sName As String
sName = Range("C" & r)
If IsNewName(sName) Then
If IsFilledAllFields(r) Then
AddToBase Range("B" & r).Resize(, 6)
End If

Else
' если НЕ новая позиция
End If
End Sub

Function IsNewName(sName As String) As Boolean
IsNewName = (Sheets("база").Columns("D:D").Find(sName) Is Nothing)
End Function

Function IsFilledAllFields(r As Long) As Boolean
IsFilledAllFields = False
Dim c As Range
For Each c In Sheets("ввод").Range("B" & r).Resize(, 6)
If Len(c.Value) = 0 Then Exit Function
Next c
IsFilledAllFields = True
End Function

Sub AddToBase(rng As Range)
With Sheets("база")
Dim lr As Long
lr = .Range("B2").End(xlDown).Row

Dim nn As Long
nn = CInt(.Range("B" & lr))

.Range("B" & lr + 1) = nn + 1
.Range("C" & lr + 1).Resize(, 6).Value = rng.Value
End With
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Me.Range(Me.Cells(Target.Row, 2), Me.Cells(Target.Row, 7)).Copy _
Sheets("таблица").[b65536].End(xlUp).Offset(1)
Cancel = True
End Sub

[/vba]

Долго искал, не могу найти. Помоги Саня

Автор - row
Дата добавления - 08.02.2012 в 04:38

Дата: Среда, 08.02.2012, 06:39 | Сообщение № 17

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 136

Репутация: 0 ±

Замечаний: 0% ±

Я другой скин сбросил по ошибке.Посмотрите Пожалуста.

Ответить

Дата: Среда, 08.02.2012, 09:28 | Сообщение № 18

Группа: Друзья

Ранг: Экселист

Сообщений: 5660

Репутация: 1163 ±

Замечаний: 0% ±

2010

Кто кодом оформил и копирайт убрал, на котором код затыкался?

>>If IsFilledAllFields®Then<<

Быть или не быть, вот в чем загвоздка!

Сообщение отредактировал RAN - Среда, 08.02.2012, 09:30

Ответить

Дата: Среда, 08.02.2012, 09:29 | Сообщение № 19

Группа: Друзья

Ранг: Ветеран

Сообщений: 1068

Репутация: 560 ±

Замечаний: 0% ±

XL 2016

в этом фрагменте
[vba]

Code

Dim nn As Long
nn = CInt(.Range("B" & lr))

[/vba]

замени CInt на CLng

Ответить

Дата: Среда, 08.02.2012, 09:41 | Сообщение № 20

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 136

Репутация: 0 ±

Замечаний: 0% ±

Саня огромное,огромное спасибо. Ты меня выручил

Ответить

Вставка строки

Страница 1 из 1
1

© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!