Excel это не сложно
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
29.03.2024, 12:56:41

Войти
На форуме добавлена возможность подписки на RSS-ленты любого раздела форума. Подписаться можно, нажав на иконку RSS , расположенную левее наименования раздела.
33 233 Сообщений в 5 454 Тем от 6 750 Пользователей
Последний пользователь: Alex1210
*
Перейти на сайт Хитрости Надстройка MulTEx Обучающие тренинги Наша группа ВКонтакте
Правила форума Начало Помощь Поиск Календарь Войти Регистрация Выйти
+  Excel это не сложно
|-+  Основные форумы
| |-+  Вопросы по Excel и VBA
| | |-+  Копирование и добавления строк в зависимости от числа в ячейке.
Страниц: [1] 2 3 ... 5   Вниз
Печать
Автор Тема: Копирование и добавления строк в зависимости от числа в ячейке.  (Прочитано 41368 раз)
0 Пользователей и 1 Гость смотрят эту тему.
iceggg
Постоялец
***

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 128


Просмотр профиля E-mail
« : 08.03.2015, 15:30:20 »

Здравствуйте. Нужна помощь с макросом. Есть таблица в ней в 13(M) столбце стоят числа надо пройтись по всей таблице скопировать строки и вставить ниже под текущей такое количество раз как число в 13 столбце текущей строки и что бы во всех вставленных строках и текущей в итоге в 13 столбце стало число 1.  Я попробовал написать макрос но так как в них не силен заблудился и застрял.
Получилась такая ерунда:
Код: (vb)
Sub azaz()

EndRow = ThisWorkbook.Sheets("Base").Cells(2, 1).End(xlDown).Row

f = 1

For x = 2 To EndRow
  p1 = Cells(x, 13).Value
  If Cells(x, 13) > 1 Then
   c = p1 - 1
    Row.Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    d = x + 1
    For Each cell In Range(Cells(d, 13), Cells(x, 13))
    Cells.Value = c
    Next cell
2:
    End If
     Cells(x, 13).Select
     If c > 1 Then GoTo 1
      Next x
     
1:
   c = Cells(x, 13).Value - 1
    Row.Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    d = x + 1 + f
    For Each cell In Range(Cells(d, 13), Cells(x, 13))
    Cells.Value = c
    Next cell
    f = f + 1
    GoTo 2
   
End Sub

Похоже оно не жизнеспособно. Выдает ошибку и выделяет желтым строку Row.Select
Записан
A-Michael
Старожил
****

Репутация: +16/-0
Офлайн Офлайн

Сообщений: 495



Просмотр профиля E-mail
« Ответ #1 : 08.03.2015, 15:41:53 »

Этот вариант у Вас не пройдёт, попробуйте что-то типа: Rows(ActiveCell.Row).Select
Записан

Я - не волшебник, я ещё только учусь...
iceggg
Постоялец
***

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 128


Просмотр профиля E-mail
« Ответ #2 : 08.03.2015, 16:10:50 »

Ага эту строчку прошло спасибо. Подскажите еще вот с этой частью:
Код: (vb)
    For Each cell In Range(Cells(d, 13), Cells(x, 13))
    Cells.Value = c
    Next cell


теперь тут на строку Cells.Value = c ругается желтым.
Записан
Alexander88
Постоялец
***

Репутация: +37/-0
Офлайн Офлайн

Сообщений: 207


Просмотр профиля
« Ответ #3 : 08.03.2015, 16:14:04 »

Так:
Код: (vb)
Cell.Value = c
Записан
iceggg
Постоялец
***

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 128


Просмотр профиля E-mail
« Ответ #4 : 08.03.2015, 16:17:50 »

Извините это я туплю мог бы и сам заметить что буква лишняя.
Записан
iceggg
Постоялец
***

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 128


Просмотр профиля E-mail
« Ответ #5 : 08.03.2015, 16:20:33 »

Он заработал но лучше бы не работал Улыбка . Выполняется до бесконечности и разносит всю таблицу в клочья. Подскажите в чем причина.
Записан
iceggg
Постоялец
***

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 128


Просмотр профиля E-mail
« Ответ #6 : 08.03.2015, 16:23:13 »

Похоже нижняя часть после 2: выполняется до бесконечности. Как сделать что бы он не лез туда когда не надо?
Записан
A-Michael
Старожил
****

Репутация: +16/-0
Офлайн Офлайн

Сообщений: 495



Просмотр профиля E-mail
« Ответ #7 : 08.03.2015, 16:24:09 »

У Вас происходит элементарное зацикливание из-за использования переходов, если Вы только не изменили код. Выложите новый вариант, если не трудно.
Записан

Я - не волшебник, я ещё только учусь...
iceggg
Постоялец
***

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 128


Просмотр профиля E-mail
« Ответ #8 : 08.03.2015, 16:25:18 »

Вот:
Код: (vb)
[Sub azaz()

EndRow = ThisWorkbook.Sheets("Base").Cells(2, 1).End(xlDown).Row

f = 1

For x = 2 To EndRow
  p1 = Cells(x, 13).Value
  If Cells(x, 13) > 1 Then
   c = p1 - 1
    Rows(ActiveCell.Row).Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    d = x + 1
    For Each Cell In Range(Cells(d, 13), Cells(x, 13))
    Cell.Value = c
    Next Cell
2:
    End If
     Cells(x, 13).Select
     If c > 1 Then GoTo 1
      Next x
     
1:
   c = Cells(x, 13).Value - 1
    Rows(ActiveCell.Row).Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    d = x + 1 + f
    For Each Cell In Range(Cells(d, 13), Cells(x, 13))
    Cell.Value = c
    Next Cell
    f = f + 1
    GoTo 2
   
End Sub

/code]
Записан
A-Michael
Старожил
****

Репутация: +16/-0
Офлайн Офлайн

Сообщений: 495



Просмотр профиля E-mail
« Ответ #9 : 08.03.2015, 16:34:12 »

Как я понял сама концепция алгоритма ошибочна. У Вас получается, что EndRow не изменяется, она используется для определения конца цикла. А в процессе работы Вы добавляете строки не в конце таблицы, а прямо в тело и когда доходите до EndRow строки у Вас получается не конец таблицы, а, грубо говоря, середина. Вам необходимо продумать этот вопрос.
Например, использовать вставку строки в начале таблицы и при этом наращивать счётчик строк на 1. А конец таблицы определять по отсутствию данных. Например так: If cells(N_Row,1)="" then ..., где N_Row счётчик строк.
« Последнее редактирование: 08.03.2015, 16:36:15 от A-Michael » Записан

Я - не волшебник, я ещё только учусь...
iceggg
Постоялец
***

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 128


Просмотр профиля E-mail
« Ответ #10 : 08.03.2015, 17:02:49 »

Строки надо вставлять обязательно под текущей строкой. А не подскажете еще куда и как прикрутить If cells(N_Row,1)="" then ..., ?
Записан
A-Michael
Старожил
****

Репутация: +16/-0
Офлайн Офлайн

Сообщений: 495



Просмотр профиля E-mail
« Ответ #11 : 08.03.2015, 17:32:54 »

По первой части вопроса - может быть есть какой-нибудь идентификатор (определитель) по которому потом, после работы программы, можно отсортировать данные?
По второй части - "прикрутить" проверку можно в начале цикла, хотя эта операцию уже циклом назвать трудно, и по истине (True) выходить из подпрограммы.
Записан

Я - не волшебник, я ещё только учусь...
iceggg
Постоялец
***

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 128


Просмотр профиля E-mail
« Ответ #12 : 08.03.2015, 17:42:10 »

Нет идентификатора никакого нет строки с одинаковыми записями могут быть в другой части таблицы. Похоже я как то неправильно приделал.

Код: (vb)
Sub azaz()

EndRow = ThisWorkbook.Sheets("Base").Cells(2, 1).End(xlDown).Row

f = 1
N_Row = 2

4:
If Cells(N_Row, 1) = "" Then GoTo 3
  p1 = Cells(N_Row, 13).Value
  If Cells(N_Row, 13) > 1 Then
   c = p1 - 1
    Rows(ActiveCell.Row).Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    d = N_Row + 1
    For Each Cell In Range(Cells(d, 13), Cells(N_Row, 13))
    Cell.Value = c
    Next Cell
2:
    End If
     Cells(N_Row, 13).Select
     If c > 1 Then GoTo 1
     If Cells(N_Row, 1) = "" Then GoTo 3
      N_Row = N_Row + 1
      GoTo 4
1:
   c = p1 - 1
    Rows(ActiveCell.Row).Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    g = g + 1
    d = N_Row + 1 + f
    For Each Cell In Range(Cells(d, 13), Cells(N_Row, 13))
    Cell.Value = c
    Next Cell
    f = f + 1
    GoTo 2
3:
End Sub

 


Оно заменяет в 13 столбце все числа начиная с 3 строки на 2 и стоит на 2 строке дергается до бесконечности.
Записан
A-Michael
Старожил
****

Репутация: +16/-0
Офлайн Офлайн

Сообщений: 495



Просмотр профиля E-mail
« Ответ #13 : 08.03.2015, 18:06:16 »

А как Вы думаете, если у Вас переход на метку 4 возвращает всё в самое начало? Попробуйте обойтись вообще без переходов GoTo и в будущем не злоупотребляете безусловными переходами.
Записан

Я - не волшебник, я ещё только учусь...
Alexander88
Постоялец
***

Репутация: +37/-0
Офлайн Офлайн

Сообщений: 207


Просмотр профиля
« Ответ #14 : 08.03.2015, 19:51:58 »

Ели правильно понял:
Код: (vb)
Sub qq()
Dim i As Integer, j As Integer, n As Integer
n = Cells(2, 1).End(xlDown).Row
For i = 2 To n
    For j = 1 To Cells(i, 13) - 1
        n = n + 1
        Range(Cells(n, 1), Cells(n, 16)) = Range(Cells(i, 1), Cells(i, 16)).Value
    Next j
Next i
Range(Cells(2, 13), Cells(n, 13)) = 1
End Sub
Записан
Страниц: [1] 2 3 ... 5   Вверх
Печать
Перейти в:  

Powered by MySQL Powered by PHP Powered by SMF 1.1.21 | SMF © 2006-2011, Simple Machines Valid XHTML 1.0! Valid CSS!
Яндекс.Метрика Рейтинг@Mail.ru