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

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

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

вставка строк (Формулы)

вставка строк

lin

Дата: Вторник, 13.08.2013, 12:19 | Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 6

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

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

Excel 2010

Есть XLS файл, состоящий из 2х листов. В 1-м листе - готовое коммерческое предложение, в котором я
ввожу код товара и автоматически вставляется строка со 2-го листа, содержащая характеристики данного товара, соответстующие
введеному коду. Вопрос: Скажите пожалуйста, можно ли сделать так, чтобы вставлялась не одна строка, а несколько строк по одному коду, допустим 10 строк,
т.к. Характеристики товара состоят из нескольих строк (параметров) ? Спасибо.

Ответить

SkyPro

Дата: Вторник, 13.08.2013, 12:34 | Сообщение № 2

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

Ранг: Старожил

Сообщений: 1206

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

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

2010

Цитата (lin, 13.08.2013 в 12:19, в сообщении №1)

Вопрос: Скажите пожалуйста, можно ли сделать так, чтобы вставлялась не одна строка, а несколько строк по одному коду, допустим 10 строк,
т.к. Характеристики товара состоят из нескольих строк (параметров) ?

Можно.

skypro1111@gmail.com

Ответить

ShAM

Дата: Вторник, 13.08.2013, 12:58 | Сообщение № 3

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

Ранг: Старожил

Сообщений: 1347

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

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

Excel 2010

Кросс:
http://www.excel-vba.ru/forum/index.php?topic=2352.0;topicseen

Ответить

lin

Дата: Вторник, 13.08.2013, 14:55 | Сообщение № 4

Группа: Пользователи

Ранг: Прохожий

Сообщений: 6

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

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

Excel 2010

ok Прикладываю файл XLS.

К сообщению приложен файл: 0620078.xlsx (10.3 Kb)

Ответить

_Boroda_

Дата: Вторник, 13.08.2013, 15:51 | Сообщение № 5

Группа: Админы

Ранг: Местный житель

Сообщений: 16787

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

Замечаний: ±

2003; 2007; 2010; 2013 RUS

Ловите

К сообщению приложен файл: 0620078_1.xlsx (12.1 Kb)

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995

Ответить

lin

Дата: Вторник, 13.08.2013, 16:33 | Сообщение № 6

Группа: Пользователи

Ранг: Прохожий

Сообщений: 6

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

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

Excel 2010

Цитата (_Boroda_, 13.08.2013 в 15:51, в сообщении №6)

Характеристики

Спасибо с одним кодом поняла, а как быть если у меня их несколько, я бы их вниз забивала, а справа все автоматически формировалось?

Ответить

Hugo

Дата: Вторник, 13.08.2013, 16:54 | Сообщение № 7

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

Ранг: Участник клуба

Сообщений: 3718

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

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

365

Можно приспособить/переделать макрос из темы http://www.excelworld.ru/forum/2-1719-1
Если нужно - могу вечером посмотреть.

Хотя если делать макрос для конкретного файла и столбца - можно всё написать иначе и проще.
По событию изменения ячейки ищем значение в базе, копируем всё что есть правее от найденной строки до строки с следующим значением.
Или пока не кончится база.

Вот, код в модуль первого листа:
[vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)
      Dim x As Range, r1 As Range, r2 As Range

      If Target.Column = 1 Then
          If Target.Cells.Count = 1 Then

              Application.EnableEvents = False
              Application.ScreenUpdating = False

              Set x = Sheets(2).Columns(1).Find(Target, , , xlWhole)
              If Not x Is Nothing Then
                  Set r1 = Target
                  Set r2 = x
                  Do
                      r2.Offset(, 1).Copy r1.Offset(, 1)
                      r2.Offset(, 2).Copy r1.Offset(, 2)
                      'или если не нужны форматы:
                      'r1.Offset(, 1) = r2.Offset(, 1)
                      'r1.Offset(, 2) = r2.Offset(, 2)
                      Set r1 = r1.Offset(1)
                      Set r2 = r2.Offset(1)
                  Loop While Len(Trim(r2.Value)) = 0 And Len(Trim(r2.Offset(, 1).Value)) > 0
              End If
              Application.ScreenUpdating = True
              Application.EnableEvents = True
          End If
      End If
End Sub

[/vba]
Или если действительно нужно строки вставлять (кроме первой!):
[vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)
     Dim x As Range, r1 As Range, r2 As Range

     If Target.Column = 1 Then
         If Target.Cells.Count = 1 Then

             Application.EnableEvents = False
             Application.ScreenUpdating = False

             Set x = Sheets(2).Columns(1).Find(Target, , , xlWhole)
             If Not x Is Nothing Then
                 Set r1 = Target
                 Set r2 = x
                 Do
                     r2.Offset(, 1).Copy r1.Offset(, 1)
                     r2.Offset(, 2).Copy r1.Offset(, 2)
                     'или если не нужны форматы:
                     'r1.Offset(, 1) = r2.Offset(, 1)
                     'r1.Offset(, 2) = r2.Offset(, 2)
                     r1.Offset(1).EntireRow.Insert
                     Set r1 = r1.Offset(1)
                     Set r2 = r2.Offset(1)
                 Loop While Len(Trim(r2.Value)) = 0 And Len(Trim(r2.Offset(, 1).Value)) > 0
                 r1.EntireRow.Delete
             End If
             Application.ScreenUpdating = True
             Application.EnableEvents = True
         End If
     End If
End Sub

[/vba]

Код

[/vba]
Или если действительно нужно строки вставлять (кроме первой!):
[vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)
     Dim x As Range, r1 As Range, r2 As Range

     If Target.Column = 1 Then
         If Target.Cells.Count = 1 Then

             Application.EnableEvents = False
             Application.ScreenUpdating = False

             Set x = Sheets(2).Columns(1).Find(Target, , , xlWhole)
             If Not x Is Nothing Then
                 Set r1 = Target
                 Set r2 = x
                 Do
                     r2.Offset(, 1).Copy r1.Offset(, 1)
                     r2.Offset(, 2).Copy r1.Offset(, 2)
                     'или если не нужны форматы:
                     'r1.Offset(, 1) = r2.Offset(, 1)
                     'r1.Offset(, 2) = r2.Offset(, 2)
                     r1.Offset(1).EntireRow.Insert
                     Set r1 = r1.Offset(1)
                     Set r2 = r2.Offset(1)
                 Loop While Len(Trim(r2.Value)) = 0 And Len(Trim(r2.Offset(, 1).Value)) > 0
                 r1.EntireRow.Delete
             End If
             Application.ScreenUpdating = True
             Application.EnableEvents = True
         End If
     End If
End Sub

[/vba]Hugo

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Ответить

СообщениеМожно приспособить/переделать макрос из темы http://www.excelworld.ru/forum/2-1719-1
Если нужно - могу вечером посмотреть.

Хотя если делать макрос для конкретного файла и столбца - можно всё написать иначе и проще.
По событию изменения ячейки ищем значение в базе, копируем всё что есть правее от найденной строки до строки с следующим значением.
Или пока не кончится база.

Вот, код в модуль первого листа:
[vba]

Код

[/vba]
Или если действительно нужно строки вставлять (кроме первой!):
[vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)
     Dim x As Range, r1 As Range, r2 As Range

     If Target.Column = 1 Then
         If Target.Cells.Count = 1 Then

             Application.EnableEvents = False
             Application.ScreenUpdating = False

             Set x = Sheets(2).Columns(1).Find(Target, , , xlWhole)
             If Not x Is Nothing Then
                 Set r1 = Target
                 Set r2 = x
                 Do
                     r2.Offset(, 1).Copy r1.Offset(, 1)
                     r2.Offset(, 2).Copy r1.Offset(, 2)
                     'или если не нужны форматы:
                     'r1.Offset(, 1) = r2.Offset(, 1)
                     'r1.Offset(, 2) = r2.Offset(, 2)
                     r1.Offset(1).EntireRow.Insert
                     Set r1 = r1.Offset(1)
                     Set r2 = r2.Offset(1)
                 Loop While Len(Trim(r2.Value)) = 0 And Len(Trim(r2.Offset(, 1).Value)) > 0
                 r1.EntireRow.Delete
             End If
             Application.ScreenUpdating = True
             Application.EnableEvents = True
         End If
     End If
End Sub

[/vba]

Автор - Hugo
Дата добавления - 13.08.2013 в 16:54

lin

Дата: Вторник, 13.08.2013, 19:04 | Сообщение № 8

Группа: Пользователи

Ранг: Прохожий

Сообщений: 6

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

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

Excel 2010

спасибо!