Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

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

 

= Мир MS Excel/Перенос данных в другой столбец по условию - Мир MS Excel

Старая форма входа
  • Страница 1 из 2
  • 1
  • 2
  • »
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос данных в другой столбец по условию (Макросы/Sub)
Перенос данных в другой столбец по условию
Driven2002 Дата: Воскресенье, 26.07.2020, 16:59 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 37
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Добрый день форумчане!

Помогите пожалуйста доработать мой код

[vba]
Код
Range(Range("a1:a2000").Find("Раздел01", , xlValues, xlWhole).Address, Range("a1:a2000").Find("раздел02", , xlValues, xlWhole).Address).Copy Range("D9:D999")
[/vba]

В настоящее время это работает так: в WORD набиваюся сведения в определенной форме, которые разделены контрольными точками Раздел01, раздел02, раздел03 и так далее.
когда сведения набиты их необходимо рассчитать по разным параметрам и для этого текст из word копируется и вставляется уже в Excel как видно из кода в столбец А. После этого запускается работа макроса, который ищет в столбце А ячеку с текстом раздел01 и раздел02 и последовательно начинает копировать все строки между контрольными словами раздел01 - раздел02, раздел02-раздел03, раздел03-раздел04 и тд. по своим столбцам.
в случае если какой именно раздел пропущен возникает ошибка, если в тексте встречается эта последовательность снова то например раздел01 - раздел02 то данные в столбе переписываются заново.

доработка кода вот так [vba]
Код
Range(Range("a1:a2000").Find("Раздел01", , xlValues, xlWhole).Address, Range("a1:a2000").Find("раздел*", , xlValues, xlWhole).Address).Copy Range("D9:D999")
[/vba]

то есть замена названия второй контрольной точки на "Раздел*". позволяет уйти от необходимости строгой последовательности расположения разделов, но тем не менее не удалось уйти от необходимости их прописывать в тексте.

1. Подскажите как доработать мой код так чтобы происходил поиск контрольной ячеки, например РАЗДЕЛ01 и если она есть то выполнять копирование данных. а если нет то искал следующую контрольную яцеку. Мысли бродят около операторов IF .... THEN, но не знаю как искать

2. Подскажите, как доработать код, так чтобы происходило добавление, повторов в заданный столбец
 
Ответить
СообщениеДобрый день форумчане!

Помогите пожалуйста доработать мой код

[vba]
Код
Range(Range("a1:a2000").Find("Раздел01", , xlValues, xlWhole).Address, Range("a1:a2000").Find("раздел02", , xlValues, xlWhole).Address).Copy Range("D9:D999")
[/vba]

В настоящее время это работает так: в WORD набиваюся сведения в определенной форме, которые разделены контрольными точками Раздел01, раздел02, раздел03 и так далее.
когда сведения набиты их необходимо рассчитать по разным параметрам и для этого текст из word копируется и вставляется уже в Excel как видно из кода в столбец А. После этого запускается работа макроса, который ищет в столбце А ячеку с текстом раздел01 и раздел02 и последовательно начинает копировать все строки между контрольными словами раздел01 - раздел02, раздел02-раздел03, раздел03-раздел04 и тд. по своим столбцам.
в случае если какой именно раздел пропущен возникает ошибка, если в тексте встречается эта последовательность снова то например раздел01 - раздел02 то данные в столбе переписываются заново.

доработка кода вот так [vba]
Код
Range(Range("a1:a2000").Find("Раздел01", , xlValues, xlWhole).Address, Range("a1:a2000").Find("раздел*", , xlValues, xlWhole).Address).Copy Range("D9:D999")
[/vba]

то есть замена названия второй контрольной точки на "Раздел*". позволяет уйти от необходимости строгой последовательности расположения разделов, но тем не менее не удалось уйти от необходимости их прописывать в тексте.

1. Подскажите как доработать мой код так чтобы происходил поиск контрольной ячеки, например РАЗДЕЛ01 и если она есть то выполнять копирование данных. а если нет то искал следующую контрольную яцеку. Мысли бродят около операторов IF .... THEN, но не знаю как искать

2. Подскажите, как доработать код, так чтобы происходило добавление, повторов в заданный столбец

Автор - Driven2002
Дата добавления - 26.07.2020 в 16:59
Hugo Дата: Воскресенье, 26.07.2020, 17:28 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3140
Репутация: 670 ±
Замечаний: 0% ±

2010, теперь уже с PQ
Добрый день.
Вот цитата из хелпа по поиску:
[vba]
Код
With Worksheets(1).Range("a1:a500")
    Set c = .Find(2, lookin:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            c.Value = 5
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With
[/vba]
Здесь видно как проверить нашлось или нет.
И как видите у меня нет никаких лишних тегов в посте...


excel@nxt.ru
webmoney: R418926282008 Z422237915069


Сообщение отредактировал Hugo - Воскресенье, 26.07.2020, 17:29
 
Ответить
СообщениеДобрый день.
Вот цитата из хелпа по поиску:
[vba]
Код
With Worksheets(1).Range("a1:a500")
    Set c = .Find(2, lookin:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            c.Value = 5
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With
[/vba]
Здесь видно как проверить нашлось или нет.
И как видите у меня нет никаких лишних тегов в посте...

Автор - Hugo
Дата добавления - 26.07.2020 в 17:28
Driven2002 Дата: Воскресенье, 26.07.2020, 22:45 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 37
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Спасибо, что дали направление куда двигаться, буду пробывать.

Вы на до мной не смейтесь, как говорят я такой специалист, первый раз видел код в книжке на полке магазина второй раз здесь, кое, что знаю но самостоятельные решения туго даються, поэтому больше работаю по обезъянему методу.

только давайте разбремся с кодом чтобы было мне понятно что я делаю
[vba]
Код


With Worksheets(1).Range("a1:a500") 'обращаемся к столбцу а с 1 по 500 ячейку на листе1
    Set c = .Find(2, lookin:=xlValues) 'устанавливаем переменную для поиска и  ищем ее. если я правильно понимаю цифру два заменяем своим значением?
    If Not c Is Nothing Then   'если это значение находим
        firstAddress = c.Address 'то запоминаем его адрес и здесь я могу вставить свой код?
        Do    
            c.Value = 5   ' после выполнения предыдущей команды и в случае если первое значение не нашли задаем новое значение для поиска?
           
'вот дальше не понятно опять устанавливаем значение для поиска и ищем его  и с чем сравнивается первый адрес?
Set c = .FindNext(c)       
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With

[/vba]


Сообщение отредактировал Driven2002 - Воскресенье, 26.07.2020, 23:05
 
Ответить
СообщениеСпасибо, что дали направление куда двигаться, буду пробывать.

Вы на до мной не смейтесь, как говорят я такой специалист, первый раз видел код в книжке на полке магазина второй раз здесь, кое, что знаю но самостоятельные решения туго даються, поэтому больше работаю по обезъянему методу.

только давайте разбремся с кодом чтобы было мне понятно что я делаю
[vba]
Код


With Worksheets(1).Range("a1:a500") 'обращаемся к столбцу а с 1 по 500 ячейку на листе1
    Set c = .Find(2, lookin:=xlValues) 'устанавливаем переменную для поиска и  ищем ее. если я правильно понимаю цифру два заменяем своим значением?
    If Not c Is Nothing Then   'если это значение находим
        firstAddress = c.Address 'то запоминаем его адрес и здесь я могу вставить свой код?
        Do    
            c.Value = 5   ' после выполнения предыдущей команды и в случае если первое значение не нашли задаем новое значение для поиска?
           
'вот дальше не понятно опять устанавливаем значение для поиска и ищем его  и с чем сравнивается первый адрес?
Set c = .FindNext(c)       
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With

[/vba]

Автор - Driven2002
Дата добавления - 26.07.2020 в 22:45
Hugo Дата: Воскресенье, 26.07.2020, 22:50 | Сообщение № 4
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3140
Репутация: 670 ±
Замечаний: 0% ±

2010, теперь уже с PQ
Так посмотреть в хелп - первое дело... Тем более что когда не работает. Ну как с инструкцией :)


excel@nxt.ru
webmoney: R418926282008 Z422237915069
 
Ответить
СообщениеТак посмотреть в хелп - первое дело... Тем более что когда не работает. Ну как с инструкцией :)

Автор - Hugo
Дата добавления - 26.07.2020 в 22:50
Driven2002 Дата: Воскресенье, 26.07.2020, 23:07 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 37
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Смотреть и читать хорошо, а когда еще и понимаешь о чем там написано так вообще святое дело. вот поэтому и прошу разъяснения этого кода
 
Ответить
СообщениеСмотреть и читать хорошо, а когда еще и понимаешь о чем там написано так вообще святое дело. вот поэтому и прошу разъяснения этого кода

Автор - Driven2002
Дата добавления - 26.07.2020 в 23:07
Hugo Дата: Понедельник, 27.07.2020, 00:04 | Сообщение № 6
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3140
Репутация: 670 ±
Замечаний: 0% ±

2010, теперь уже с PQ
Ну там далее пример поиска всех следующих двоек, т.е. ищем двойки пока адрес очередной найденной не совпадёт с адресом первой. Это Вам сейчас не надо, главное это как проверить что диапазон найден.


excel@nxt.ru
webmoney: R418926282008 Z422237915069
 
Ответить
СообщениеНу там далее пример поиска всех следующих двоек, т.е. ищем двойки пока адрес очередной найденной не совпадёт с адресом первой. Это Вам сейчас не надо, главное это как проверить что диапазон найден.

Автор - Hugo
Дата добавления - 27.07.2020 в 00:04
Driven2002 Дата: Понедельник, 27.07.2020, 00:10 | Сообщение № 7
Группа: Пользователи
Ранг: Новичок
Сообщений: 37
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
однозначно не пойму что делает эта чать кода
[vba]
Код

Do    
            c.Value = 5   ' все искомые значения по ячейкам заменяются на цифру 5
            Set c = .FindNext(c)       
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With
[/vba]

и как мне запустить поиск заново, по первому критерию. получатся если второй раз встречается значение ячейки "раздел01" то происходит копирование от "раздел02" до новой ячейки

первая часть кода работает как надо

[vba]
Код
With Range("a1:a500")
    Set c = .Find("Раздел01", LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Range(Range("a1:a2000").Find("раздел01", , xlValues, xlWhole).Address, Range("a1:a2000").Find("раздел*", , xlValues, xlWhole).Address).Copy Range("D9:D999")
[/vba]


Сообщение отредактировал Driven2002 - Понедельник, 27.07.2020, 00:13
 
Ответить
Сообщениеоднозначно не пойму что делает эта чать кода
[vba]
Код

Do    
            c.Value = 5   ' все искомые значения по ячейкам заменяются на цифру 5
            Set c = .FindNext(c)       
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With
[/vba]

и как мне запустить поиск заново, по первому критерию. получатся если второй раз встречается значение ячейки "раздел01" то происходит копирование от "раздел02" до новой ячейки

первая часть кода работает как надо

[vba]
Код
With Range("a1:a500")
    Set c = .Find("Раздел01", LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Range(Range("a1:a2000").Find("раздел01", , xlValues, xlWhole).Address, Range("a1:a2000").Find("раздел*", , xlValues, xlWhole).Address).Copy Range("D9:D999")
[/vba]

Автор - Driven2002
Дата добавления - 27.07.2020 в 00:10
Hugo Дата: Понедельник, 27.07.2020, 00:20 | Сообщение № 8
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3140
Репутация: 670 ±
Замечаний: 0% ±

2010, теперь уже с PQ
Та часть кода делает то что я описал чуть выше.
А по Вашей задаче ничего не скажу ибо её не вижу.


excel@nxt.ru
webmoney: R418926282008 Z422237915069
 
Ответить
СообщениеТа часть кода делает то что я описал чуть выше.
А по Вашей задаче ничего не скажу ибо её не вижу.

Автор - Hugo
Дата добавления - 27.07.2020 в 00:20
Driven2002 Дата: Понедельник, 27.07.2020, 00:31 | Сообщение № 9
Группа: Пользователи
Ранг: Новичок
Сообщений: 37
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
так получается что макрос ищет все 2 и меняет их на 5

а мне надо что бы макрос нашел все двойки скопировал их в другой столбец
 
Ответить
Сообщениетак получается что макрос ищет все 2 и меняет их на 5

а мне надо что бы макрос нашел все двойки скопировал их в другой столбец

Автор - Driven2002
Дата добавления - 27.07.2020 в 00:31
Hugo Дата: Понедельник, 27.07.2020, 00:35 | Сообщение № 10
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3140
Репутация: 670 ±
Замечаний: 0% ±

2010, теперь уже с PQ
Ну так и делайте. Кроме значения у диапазона есть адрес, номер строки, столбца... Сама найденная ячейка.


excel@nxt.ru
webmoney: R418926282008 Z422237915069
 
Ответить
СообщениеНу так и делайте. Кроме значения у диапазона есть адрес, номер строки, столбца... Сама найденная ячейка.

Автор - Hugo
Дата добавления - 27.07.2020 в 00:35
Driven2002 Дата: Понедельник, 27.07.2020, 01:01 | Сообщение № 11
Группа: Пользователи
Ранг: Новичок
Сообщений: 37
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
вот смотрите пример на листе1 идет неповторяющаяся последовательность и она распределяется по другим столбикам без проблем

на листе2 в эту последовательность включен уже повторяющееся значение и его код уже не видит
К сообщению приложен файл: 1274601.xlsm(27.6 Kb)
 
Ответить
Сообщениевот смотрите пример на листе1 идет неповторяющаяся последовательность и она распределяется по другим столбикам без проблем

на листе2 в эту последовательность включен уже повторяющееся значение и его код уже не видит

Автор - Driven2002
Дата добавления - 27.07.2020 в 01:01
Hugo Дата: Понедельник, 27.07.2020, 01:10 | Сообщение № 12
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3140
Репутация: 670 ±
Замечаний: 0% ±

2010, теперь уже с PQ
Вам Do-Loop тут вообще не нужно, да и адрес запоминать не нужно.
Если известно что разделов всегда 5, то в цикле от 1 до 4 ищем по этим парам, и если оба значения нашли, то копируем.
Вот код для второго листа (да и первого, но проверил на втором):
[vba]
Код

Private Sub CommandButton1_Click()
    Dim c1 As Range, c2 As Range

    With Range("a1:a500")
        For i = 1 To 4
            Set c1 = .Find("раздел0" & i, LookIn:=xlValues)
            If Not c1 Is Nothing Then
                Set c2 = .Find("раздел0" & i + 1, LookIn:=xlValues)
                If Not c2 Is Nothing Then
                    Range(c1.Address, c2.Address).Copy Cells(9, i + 3)

                End If
            End If
        Next
    End With

End Sub
[/vba]


excel@nxt.ru
webmoney: R418926282008 Z422237915069


Сообщение отредактировал Hugo - Понедельник, 27.07.2020, 01:15
 
Ответить
СообщениеВам Do-Loop тут вообще не нужно, да и адрес запоминать не нужно.
Если известно что разделов всегда 5, то в цикле от 1 до 4 ищем по этим парам, и если оба значения нашли, то копируем.
Вот код для второго листа (да и первого, но проверил на втором):
[vba]
Код

Private Sub CommandButton1_Click()
    Dim c1 As Range, c2 As Range

    With Range("a1:a500")
        For i = 1 To 4
            Set c1 = .Find("раздел0" & i, LookIn:=xlValues)
            If Not c1 Is Nothing Then
                Set c2 = .Find("раздел0" & i + 1, LookIn:=xlValues)
                If Not c2 Is Nothing Then
                    Range(c1.Address, c2.Address).Copy Cells(9, i + 3)

                End If
            End If
        Next
    End With

End Sub
[/vba]

Автор - Hugo
Дата добавления - 27.07.2020 в 01:10
Driven2002 Дата: Понедельник, 27.07.2020, 01:15 | Сообщение № 13
Группа: Пользователи
Ранг: Новичок
Сообщений: 37
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Смотрите я не копирую значение ячейки. я копирую диапазон ячеек между этими разделами и мне нужно если встретилось повторение то новый диапазон скопировать, то есть добавить к уже скопированному разделы могут быть и пропущены, и содержать названия без цифр
 
Ответить
СообщениеСмотрите я не копирую значение ячейки. я копирую диапазон ячеек между этими разделами и мне нужно если встретилось повторение то новый диапазон скопировать, то есть добавить к уже скопированному разделы могут быть и пропущены, и содержать названия без цифр

Автор - Driven2002
Дата добавления - 27.07.2020 в 01:15
Hugo Дата: Понедельник, 27.07.2020, 01:17 | Сообщение № 14
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3140
Репутация: 670 ±
Замечаний: 0% ±

2010, теперь уже с PQ
Да, и с первым листом отработало.
Ну а если там повторы и добавлять - то проще не find, а циклом и собирать в словарь с коллекцией, затем этот словарь выгружать куда угодно.
И тогда все без цифр будут в одной кучке.
[vba]
Код

Sub tt()
    Dim i&, t$, el

    With CreateObject("Scripting.Dictionary")
        For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
            If Len(Cells(i, 1)) Then
                If InStr(Cells(i, 1), "раздел") Then
                    t = Cells(i, 1)
                Else
                    If Not .exists(t) Then .Add t, New Collection
                    .Item(t).Add Cells(i, 1).Value
                End If
            End If
        Next

        For Each el In .keys
            For Each col In .Item(el)
                MsgBox el & " = " & col
            Next
        Next
    End With

End Sub
[/vba]


excel@nxt.ru
webmoney: R418926282008 Z422237915069


Сообщение отредактировал Hugo - Понедельник, 27.07.2020, 01:34
 
Ответить
СообщениеДа, и с первым листом отработало.
Ну а если там повторы и добавлять - то проще не find, а циклом и собирать в словарь с коллекцией, затем этот словарь выгружать куда угодно.
И тогда все без цифр будут в одной кучке.
[vba]
Код

Sub tt()
    Dim i&, t$, el

    With CreateObject("Scripting.Dictionary")
        For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
            If Len(Cells(i, 1)) Then
                If InStr(Cells(i, 1), "раздел") Then
                    t = Cells(i, 1)
                Else
                    If Not .exists(t) Then .Add t, New Collection
                    .Item(t).Add Cells(i, 1).Value
                End If
            End If
        Next

        For Each el In .keys
            For Each col In .Item(el)
                MsgBox el & " = " & col
            Next
        Next
    End With

End Sub
[/vba]

Автор - Hugo
Дата добавления - 27.07.2020 в 01:17
Driven2002 Дата: Вторник, 28.07.2020, 22:16 | Сообщение № 15
Группа: Пользователи
Ранг: Новичок
Сообщений: 37
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Спасибо большое Hugo за помощь и ваше терпение при ответе на мои дилетантские вопросы.


Сообщение отредактировал Driven2002 - Вторник, 28.07.2020, 22:17
 
Ответить
СообщениеСпасибо большое Hugo за помощь и ваше терпение при ответе на мои дилетантские вопросы.

Автор - Driven2002
Дата добавления - 28.07.2020 в 22:16
Driven2002 Дата: Вторник, 28.07.2020, 23:01 | Сообщение № 16
Группа: Пользователи
Ранг: Новичок
Сообщений: 37
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Спасибо большое Hugo за помощь и ваше терпение при ответе на мои дилетантские вопросы. Нет цены вашей помощи

это код просто сказка. то что я делал построчно для 60 разделов вместилось в 12 строк кода, обалдеть

[vba]
Код

Dim c1 As Range, c2 As Range 'задаем переменные куда будем копировать найденные адреса
    With Range("a1:a500") ' задаем область поиска, в данном случае столбец A
        For i = 1 To 2 ' запускаем цикл для перебора всех значение от одного
        'до конечного значения, которое должно быть меньше на 1 количества разделов
            Set c1 = .Find("раздел0" & i, LookIn:=xlValues) 'ищем первое значение
            If Not c1 Is Nothing Then  'если первое значение найдено, то переходим к поиску второго значения
                Set c2 = .Find("раздел0" & i + 1, LookIn:=xlValues) 'ищем второе значение, со следующей
                'строки, для этого увеличиваем на один адрес строчки первого значения
                If Not c2 Is Nothing Then 'если второе значение найдено, то переходим к копированию диапазона
                    Range(c1.Address, c2.Address).Copy Cells(9, i + 3) 'копируем область между с1 и с2 в ячейку 9 4 столба
                End If
            End If
        Next
    End With
End Sub
[/vba]

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

придумал такой вод код. для перетасовки сведений на основе функции Range("e" & i).CurrentRegion.Copy

[vba]
Код

Private Sub CommandButton2_Click()

Range("B1") = "ромашка"
Range("B2") = Range("E1")
Dim i, i1, lLastRow As Long
  For i = 1 To 40  'задаем диапазон поиска в столбце
    If Range("e" & i) = "ромашка" Then   'ищем ячейку со своим значением
    'MsgBox Range("e" & i).Address
    lLastRow = Cells(Rows.Count, 2).End(xlUp).Row  'определяем строку полседней зянятой ячейки в столбце 13
    Range("e" & i).CurrentRegion.Copy Range("B" & lLastRow + 2) 'копируем диапазон заполненых ячеек вниз и право от заданной ячейки в столбец он же 13
    End If
  Next
  
  lLastRow = Cells(Rows.Count, 2).End(xlUp).Row
  Range("B" & lLastRow + 2) = Range("g1")
For i1 = 1 To 40  'задаем диапазон поиска в столбце
    
    If Range("g" & i1) = "ромашка" Then   'ищем ячейку со своим значением
    'MsgBox Range("e" & i).Address
    lLastRow = Cells(Rows.Count, 2).End(xlUp).Row  'определяем строку полседней зянятой ячейки в столбце 13
    Range("g" & i1).CurrentRegion.Copy Range("B" & lLastRow + 2) 'копируем диапазон заполненых ячеек вниз и право от заданной ячейки в столбец он же 13
    End If
  Next
  
  lLastRow = Cells(Rows.Count, 2).End(xlUp).Row
  Range("B" & lLastRow + 2) = "ВАСЕЛЬКИ"
  Range("B" & lLastRow + 4) = Range("E1")
   
  
End Sub
[/vba]

но код копирует все от найденной ячейки до пустой захватывая ячейки соседних столбцов справа и слева (лист 2 прилагаемого файла), а мне необходимо копировать область ниже найденной до пустой и размещать все это в один столбик. как на листе1 прилагаемого файла.

К сообщению приложен файл: 2028389.xlsm(65.6 Kb)
 
Ответить
СообщениеСпасибо большое Hugo за помощь и ваше терпение при ответе на мои дилетантские вопросы. Нет цены вашей помощи

это код просто сказка. то что я делал построчно для 60 разделов вместилось в 12 строк кода, обалдеть

[vba]
Код

Dim c1 As Range, c2 As Range 'задаем переменные куда будем копировать найденные адреса
    With Range("a1:a500") ' задаем область поиска, в данном случае столбец A
        For i = 1 To 2 ' запускаем цикл для перебора всех значение от одного
        'до конечного значения, которое должно быть меньше на 1 количества разделов
            Set c1 = .Find("раздел0" & i, LookIn:=xlValues) 'ищем первое значение
            If Not c1 Is Nothing Then  'если первое значение найдено, то переходим к поиску второго значения
                Set c2 = .Find("раздел0" & i + 1, LookIn:=xlValues) 'ищем второе значение, со следующей
                'строки, для этого увеличиваем на один адрес строчки первого значения
                If Not c2 Is Nothing Then 'если второе значение найдено, то переходим к копированию диапазона
                    Range(c1.Address, c2.Address).Copy Cells(9, i + 3) 'копируем область между с1 и с2 в ячейку 9 4 столба
                End If
            End If
        Next
    End With
End Sub
[/vba]

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

придумал такой вод код. для перетасовки сведений на основе функции Range("e" & i).CurrentRegion.Copy

[vba]
Код

Private Sub CommandButton2_Click()

Range("B1") = "ромашка"
Range("B2") = Range("E1")
Dim i, i1, lLastRow As Long
  For i = 1 To 40  'задаем диапазон поиска в столбце
    If Range("e" & i) = "ромашка" Then   'ищем ячейку со своим значением
    'MsgBox Range("e" & i).Address
    lLastRow = Cells(Rows.Count, 2).End(xlUp).Row  'определяем строку полседней зянятой ячейки в столбце 13
    Range("e" & i).CurrentRegion.Copy Range("B" & lLastRow + 2) 'копируем диапазон заполненых ячеек вниз и право от заданной ячейки в столбец он же 13
    End If
  Next
  
  lLastRow = Cells(Rows.Count, 2).End(xlUp).Row
  Range("B" & lLastRow + 2) = Range("g1")
For i1 = 1 To 40  'задаем диапазон поиска в столбце
    
    If Range("g" & i1) = "ромашка" Then   'ищем ячейку со своим значением
    'MsgBox Range("e" & i).Address
    lLastRow = Cells(Rows.Count, 2).End(xlUp).Row  'определяем строку полседней зянятой ячейки в столбце 13
    Range("g" & i1).CurrentRegion.Copy Range("B" & lLastRow + 2) 'копируем диапазон заполненых ячеек вниз и право от заданной ячейки в столбец он же 13
    End If
  Next
  
  lLastRow = Cells(Rows.Count, 2).End(xlUp).Row
  Range("B" & lLastRow + 2) = "ВАСЕЛЬКИ"
  Range("B" & lLastRow + 4) = Range("E1")
   
  
End Sub
[/vba]

но код копирует все от найденной ячейки до пустой захватывая ячейки соседних столбцов справа и слева (лист 2 прилагаемого файла), а мне необходимо копировать область ниже найденной до пустой и размещать все это в один столбик. как на листе1 прилагаемого файла.


Автор - Driven2002
Дата добавления - 28.07.2020 в 23:01
Driven2002 Дата: Среда, 29.07.2020, 01:10 | Сообщение № 17
Группа: Пользователи
Ранг: Новичок
Сообщений: 37
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Нашел я решение своей проблемы вот так
[vba]
Код
Dim c1 As Range, c2 As Range 'задаем переменные куда будем копировать найденные адреса
Dim i, i1 As Integer
    With Range("a1:a500") ' задаем область поиска, в данном случае столбец A
    For i = 1 To 100  'задаем диапазон поиска в столбце
    If Range("a" & i) = "ромашка" Then   'ищем ячейку со своим значением
    Set c1 = Range("a" & i) 'запоминаем найденную ячейку
    For i1 = 1 To 6 'задаем диапазон поиска в столбце
    If Len(Cells(c1.Row + i1, 1)) Then 'проверяем ячейки на содержание записей
    'MsgBox Cells(c1.Row + i1, 1).Address
    Else
    Set c2 = Cells(c1.Row + i1, 1) 'запоминаем пустую ячейку
   ' MsgBox "пусто" & Cells(c1.Row + i1, 1).Address
    lLastRow = Cells(Rows.Count, 4).End(xlUp).Row 'определяем строку последней занятой ячейки в столбце
    Range(c1.Address, c2.Address).Copy Range("d" & lLastRow + 2) 'копируем область между с1 и с2 в последнюю занятую ячейку столбца D
    Exit For 'Выходим из цикла если найдена пустай ячейка
    End If 'Выходим из условия по проверки занятой ячейки
    Next 'если пустая ячейка не найдена продолжаем цикл
    End If 'Выходим из поиска если искомого значения
    Next 'продолжаем поиск искомого значения
    End With
End Sub
[/vba]

теперь остается вопрос как собрать все источники автоматически, из каждого столбика по источникам и видам как на листе1, вручную последовательно я уже могу сделать своим кодом
К сообщению приложен файл: 6892478.xlsm(80.9 Kb)
 
Ответить
СообщениеНашел я решение своей проблемы вот так
[vba]
Код
Dim c1 As Range, c2 As Range 'задаем переменные куда будем копировать найденные адреса
Dim i, i1 As Integer
    With Range("a1:a500") ' задаем область поиска, в данном случае столбец A
    For i = 1 To 100  'задаем диапазон поиска в столбце
    If Range("a" & i) = "ромашка" Then   'ищем ячейку со своим значением
    Set c1 = Range("a" & i) 'запоминаем найденную ячейку
    For i1 = 1 To 6 'задаем диапазон поиска в столбце
    If Len(Cells(c1.Row + i1, 1)) Then 'проверяем ячейки на содержание записей
    'MsgBox Cells(c1.Row + i1, 1).Address
    Else
    Set c2 = Cells(c1.Row + i1, 1) 'запоминаем пустую ячейку
   ' MsgBox "пусто" & Cells(c1.Row + i1, 1).Address
    lLastRow = Cells(Rows.Count, 4).End(xlUp).Row 'определяем строку последней занятой ячейки в столбце
    Range(c1.Address, c2.Address).Copy Range("d" & lLastRow + 2) 'копируем область между с1 и с2 в последнюю занятую ячейку столбца D
    Exit For 'Выходим из цикла если найдена пустай ячейка
    End If 'Выходим из условия по проверки занятой ячейки
    Next 'если пустая ячейка не найдена продолжаем цикл
    End If 'Выходим из поиска если искомого значения
    Next 'продолжаем поиск искомого значения
    End With
End Sub
[/vba]

теперь остается вопрос как собрать все источники автоматически, из каждого столбика по источникам и видам как на листе1, вручную последовательно я уже могу сделать своим кодом

Автор - Driven2002
Дата добавления - 29.07.2020 в 01:10
Driven2002 Дата: Пятница, 31.07.2020, 23:27 | Сообщение № 18
Группа: Пользователи
Ранг: Новичок
Сообщений: 37
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
1


Сообщение отредактировал Driven2002 - Суббота, 01.08.2020, 00:06
 
Ответить
Сообщение1

Автор - Driven2002
Дата добавления - 31.07.2020 в 23:27
Hugo Дата: Суббота, 01.08.2020, 14:11 | Сообщение № 19
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3140
Репутация: 670 ±
Замечаний: 0% ±

2010, теперь уже с PQ
Вообще пришлось потратить определённое время чтоб найти в этой куче тот код, который вероятно нужно изучить. Нашёл вроде, хотя не факт...
как его потом вытянуть в нужные мне столбцы

- т.к. я не в курсе (и до сих пор :) ) какие столбцы нужные и как желаете вытягивать, то это в коде на словаре оставлено на доработку.
Вот смотрите:
[vba]
Код

        For Each el In .keys 'перебор ключей, как перейдёте на следующий - можно поменять столбец или что угодно
            For Each col In .Item(el)'перебор содержимого собранной коллекции для каждого ключа, как перейдёте на следующий - можно поменять например строку, или что угодно
                MsgBox el & " = " & col
            Next
        Next

[/vba]
Ну и вместо MsgBox el & " = " & col можете написать например
cells(x,y)=col
при условии что при смене ключа увеличивали y, а при смене элемента коллекции x


excel@nxt.ru
webmoney: R418926282008 Z422237915069


Сообщение отредактировал Hugo - Суббота, 01.08.2020, 14:13
 
Ответить
СообщениеВообще пришлось потратить определённое время чтоб найти в этой куче тот код, который вероятно нужно изучить. Нашёл вроде, хотя не факт...
как его потом вытянуть в нужные мне столбцы

- т.к. я не в курсе (и до сих пор :) ) какие столбцы нужные и как желаете вытягивать, то это в коде на словаре оставлено на доработку.
Вот смотрите:
[vba]
Код

        For Each el In .keys 'перебор ключей, как перейдёте на следующий - можно поменять столбец или что угодно
            For Each col In .Item(el)'перебор содержимого собранной коллекции для каждого ключа, как перейдёте на следующий - можно поменять например строку, или что угодно
                MsgBox el & " = " & col
            Next
        Next

[/vba]
Ну и вместо MsgBox el & " = " & col можете написать например
cells(x,y)=col
при условии что при смене ключа увеличивали y, а при смене элемента коллекции x

Автор - Hugo
Дата добавления - 01.08.2020 в 14:11
Driven2002 Дата: Суббота, 01.08.2020, 23:03 | Сообщение № 20
Группа: Пользователи
Ранг: Новичок
Сообщений: 37
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Уважаемый Hugo ваша помощь не оценима и вы мне уже помогли решить эту задачу с копированием диапазона по разделам, без словарей, я получил у меня получилось что надо. теперь я ломаю голову как мне скопировать уже так сказать локальные разделки последовательно друг за другом

что бы вы лучше поняли что я хочу и понимали мои невнятные объяснения я вам прикладываю вам прикладываю реальный документ WORD который формируется и загружается в Excel для автоматического расчета и файл Excel где уже реализована кнопка "Разделить сводку" разбивки на разделы, на разделы я разбиваю потому что нужно провести расчеты по видам преступлений и это я знаю как делать формулами эксель. Если бы знал в совершенстве VBA сделал бы кодом, меньше бы ресурсов потребовалось и на разделы бы не пришлось бить.

Теперь стоит задача из общей сводки по видам преступлений сформировать сводку по территории совершения и по видам преступлений например 1 все сообщения умвд по городу по видам преступлений (Убийства. кражи, поджоги...), затем по-1 по городу по видам преступлений (Убийства. кражи, поджоги...), затем по-2 по городу по видам преступлений (Убийства. кражи, поджоги...), затем Вяземский по видам преступлений (Убийства. кражи, поджоги...), ну т.д.

 
Ответить
СообщениеУважаемый Hugo ваша помощь не оценима и вы мне уже помогли решить эту задачу с копированием диапазона по разделам, без словарей, я получил у меня получилось что надо. теперь я ломаю голову как мне скопировать уже так сказать локальные разделки последовательно друг за другом

что бы вы лучше поняли что я хочу и понимали мои невнятные объяснения я вам прикладываю вам прикладываю реальный документ WORD который формируется и загружается в Excel для автоматического расчета и файл Excel где уже реализована кнопка "Разделить сводку" разбивки на разделы, на разделы я разбиваю потому что нужно провести расчеты по видам преступлений и это я знаю как делать формулами эксель. Если бы знал в совершенстве VBA сделал бы кодом, меньше бы ресурсов потребовалось и на разделы бы не пришлось бить.

Теперь стоит задача из общей сводки по видам преступлений сформировать сводку по территории совершения и по видам преступлений например 1 все сообщения умвд по городу по видам преступлений (Убийства. кражи, поджоги...), затем по-1 по городу по видам преступлений (Убийства. кражи, поджоги...), затем по-2 по городу по видам преступлений (Убийства. кражи, поджоги...), затем Вяземский по видам преступлений (Убийства. кражи, поджоги...), ну т.д.


Автор - Driven2002
Дата добавления - 01.08.2020 в 23:03
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос данных в другой столбец по условию (Макросы/Sub)
  • Страница 1 из 2
  • 1
  • 2
  • »
Поиск:

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