Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Копирование изменяемого столбца диапазона ячеек, Копирование изменяемого диапазона ячеек эксель
 
#1
02.11.2022 19:23:53
Как сделать чтобы копировались со столбца только определенные ячейки?
Например как на скриншоте, чтобы копирование начиналось от даты и заканчивалось
например большой буквой Ж или П, и вставлялись по отдельности?
Изменено: Юрий М - 02.11.2022 20:39:05
 
 
 
#2
02.11.2022 19:34:50
Назар Скалат,  переформулируйте и предложите новое название темы, из которого будет понятна задача - модераторы поменяют.
 
 
 
#3
02.11.2022 19:55:34
Цитата
написал:
Назар Скалат,  переформулируйте и предложите новое название темы, из которого будет понятна задача - модераторы поменяют.
Копирование изменяемого столбца диапазона ячеек эксель
 
 
 
#4
02.11.2022 20:39:40
Я бы и без цитаты понял.
Название поменял.
 
 
 
#5
03.11.2022 11:03:00
Назар Скалат, макрос подойдёт?
С вас файл-пример
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#6
03.11.2022 11:08:22
Цитата
написал:
Назар Скалат, макрос подойдёт?
С вас файл-пример
 
 
 
#7
03.11.2022 11:11:15
Цитата
написал:
Назар Скалат, макрос подойдёт?
С вас файл-пример
Данные могут иметь в столбце 2 ячейки, 3 ячейки, 5 ячеек, и мне нужно чтобы как-то они копировались по отдельно, оно все идет в одном столбце, можно ли чтобы эксель как-то сам определял дата это начало копирование, а большая буква "В", "Н", "П" это конец и копировал в другой столбец? (Дата может быть разной).
Изменено: Назар Скалат - 03.11.2022 11:11:43
 
 
 
#8
03.11.2022 11:39:22
Скрин. Файл. Код
Даблклик по ячейке A1 запустит макрос.
Данные должны начинаться с A1.
Пустые и ошибки пропускает.
Делит первый столбец на блоки от даты и до следующей даты.
Изменено: Jack Famous - 03.11.2022 15:15:07
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#9
03.11.2022 12:00:12
Код
Sub qq()
    Dim lr&, lrow&, i&, j&, k&
    lr = Cells(Rows.Count, 1).End(xlUp).Row + 1
    Range("A1").Resize(lr).AutoFilter Field:=1, Criteria1:="<>"
    k = 1: j = 4
    For i = 2 To lr
        If IsDate(Range("A" & i)) Or i = lr Then
            lrow = Cells(Rows.Count, j).End(xlUp).Row + 1
            If lrow = 2 Then lrow = 1
            Range("A" & k & ":A" & i - 1).Copy Cells(lrow, j)
            k = i
            j = j + 1
            If j > 6 Then j = 4
        End If
    Next
End Sub
Изменено: RAN - 03.11.2022 12:13:50
 
 
 
#10
03.11.2022 12:48:04
Цитата
написал:
    Скрин. Файл. Код            Скрин               Файл          SplitColumn.xlsb    (16.33 КБ)       Код        
Код
    [URL=#]?[/URL]       1  2  3  4  5  6  7  8  9  10  11  12  13  14  15  16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31  32  33  34  35  36  37  38  39  40  41  42  43      'Option Base 1    Option   Explicit    'Option Private Module    '==================================================================================================    Sub   Splitter()    Dim   arr, aOut()    Dim   t!, r&, rF&, rP&, rMax&, rr&, cc&    Dim   DS$       t = Timer    r = Cells(Rows.Count, 1).  End  (xlUp).Row    arr = Cells(1, 1).Resize(r, 1).Value    ReDim   aOut(1   To   UBound(arr, 1), 1   To   UBound(arr, 1))    aOut(1, 1) = arr(1, 1): rF = 1    DS = Application.International(xlDateSeparator)       For   r = 2   To   UBound(arr, 1)          If   IsError(arr(r, 1))   Then   GoTo   nxR   Else   If   Len(arr(r, 1)) = 0   Then   GoTo   nxR             If   IsDate(Replace$(arr(r, 1),   "."  , DS))   Then              cc = cc + 1                       For   rP = rF   To   r - 1                  If   IsError(arr(rP, 1))   Then   GoTo   nxP   Else   If   Len(arr(rP, 1)) = 0   Then   GoTo   nxP                  rr = rr + 1: aOut(rr, cc) = arr(rP, 1)    nxP:      Next   rP                 If   rMax < rr   Then   rMax = rr              rF = r: rr = 0          End   If    nxR:    Next   r       If   cc = 0   Then   MsgBox   "Only ONE block!"  , vbExclamation,   "NOTHING"  :   Exit   Sub       With   ActiveSheet.UsedRange          [c1].Resize(.Rows.Count, .Columns.Count).ClearContents    End   With       [c1].Resize(rMax, cc).Value = aOut    MsgBox   "DONE"  , vbInformation, Format$(Timer - t,   "0.00 sec"  )    End   Sub    '==================================================================================================  
  Даблклик по ячейке A1 запустит макрос.
Данные должны начинаться с A1.
Пустые и ошибки пропускает.
Делит первый столбец на блоки от даты и до следующей даты.
Спасибо, все работает! Подскажите вы сами пишите макросы или есть где-то в интернете список с макросами а там можно под себя настроить?
 
 
 
#11
03.11.2022 12:48:17
Цитата
написал:
Код
    [URL=#]?[/URL]       1  2  3  4  5  6  7  8  9  10  11  12  13  14  15  16      Sub   qq()          Dim   lr&, lrow&, i&, j&, k&          lr = Cells(Rows.Count, 1).  End  (xlUp).Row + 1          Range(  "A1"  ).Resize(lr).AutoFilter Field:=1, Criteria1:=  "<>"          k = 1: j = 4          For   i = 2   To   lr              If   IsDate(Range(  "A"   & i))   Or   i = lr   Then                  lrow = Cells(Rows.Count, j).  End  (xlUp).Row + 1                  If   lrow = 2   Then   lrow = 1                  Range(  "A"   & k &   ":A"   & i - 1).Copy Cells(lrow, j)                  k = i                  j = j + 1                  If   j > 6   Then   j = 4              End   If          Next    End   Sub  
 
Спасибо.
 
 
 
#12
03.11.2022 13:03:45
Цитата
написал:
Код
    [URL=#]?[/URL]       1  2  3  4  5  6  7  8  9  10  11  12  13  14  15  16      Sub   qq()          Dim   lr&, lrow&, i&, j&, k&          lr = Cells(Rows.Count, 1).  End  (xlUp).Row + 1          Range(  "A1"  ).Resize(lr).AutoFilter Field:=1, Criteria1:=  "<>"          k = 1: j = 4          For   i = 2   To   lr              If   IsDate(Range(  "A"   & i))   Or   i = lr   Then                  lrow = Cells(Rows.Count, j).  End  (xlUp).Row + 1                  If   lrow = 2   Then   lrow = 1                  Range(  "A"   & k &   ":A"   & i - 1).Copy Cells(lrow, j)                  k = i                  j = j + 1                  If   j > 6   Then   j = 4              End   If          Next    End   Sub  
 
Посмотрите, как-то некоректно копирует если беру другие данные и вставляю в таблицу, просто не всегда выходит копирование из столбца там 4, 5 ячеек, иногда может быть так, что нужно будет чтобы скопировались и 8 ячеек. Мне нужно чтобы копировались значения от даты до второй даты с изменяющимся диапазоном.  
 
 
 
#13
03.11.2022 13:09:08
Цитата
написал:
    Скрин. Файл. Код            Скрин               Файл          SplitColumn.xlsb    (16.33 КБ)       Код        
Код
    [URL=#]?[/URL]       1  2  3  4  5  6  7  8  9  10  11  12  13  14  15  16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31  32  33  34  35  36  37  38  39  40  41  42  43      'Option Base 1    Option   Explicit    'Option Private Module    '==================================================================================================    Sub   Splitter()    Dim   arr, aOut()    Dim   t!, r&, rF&, rP&, rMax&, rr&, cc&    Dim   DS$       t = Timer    r = Cells(Rows.Count, 1).  End  (xlUp).Row    arr = Cells(1, 1).Resize(r, 1).Value    ReDim   aOut(1   To   UBound(arr, 1), 1   To   UBound(arr, 1))    aOut(1, 1) = arr(1, 1): rF = 1    DS = Application.International(xlDateSeparator)       For   r = 2   To   UBound(arr, 1)          If   IsError(arr(r, 1))   Then   GoTo   nxR   Else   If   Len(arr(r, 1)) = 0   Then   GoTo   nxR             If   IsDate(Replace$(arr(r, 1),   "."  , DS))   Then              cc = cc + 1                       For   rP = rF   To   r - 1                  If   IsError(arr(rP, 1))   Then   GoTo   nxP   Else   If   Len(arr(rP, 1)) = 0   Then   GoTo   nxP                  rr = rr + 1: aOut(rr, cc) = arr(rP, 1)    nxP:      Next   rP                 If   rMax < rr   Then   rMax = rr              rF = r: rr = 0          End   If    nxR:    Next   r       If   cc = 0   Then   MsgBox   "Only ONE block!"  , vbExclamation,   "NOTHING"  :   Exit   Sub       With   ActiveSheet.UsedRange          [c1].Resize(.Rows.Count, .Columns.Count).ClearContents    End   With       [c1].Resize(rMax, cc).Value = aOut    MsgBox   "DONE"  , vbInformation, Format$(Timer - t,   "0.00 sec"  )    End   Sub    '==================================================================================================  
  Даблклик по ячейке A1 запустит макрос.
Данные должны начинаться с A1.
Пустые и ошибки пропускает.
Делит первый столбец на блоки от даты и до следующей даты.
Извините, не тот скрин и файл скинул. Вот смотрите:
 
 
 
#14
03.11.2022 13:26:28
Назар Скалат, не нужно постоянно цитировать всё подряд

Цитата
Назар Скалат: как-то некоректно копирует
В данных у вас ЧТО? Проблема не на моей стороне…
Какой стол — такой и стул)))

Цитата
Назар Скалат: вы сами пишите макросы или есть где-то в интернете список с макросами а там можно под себя настроить?
я пишу сам и это лучший вариант  :D
Макросов полно, некоторые можно адаптировать…
Изменено: Jack Famous - 03.11.2022 13:34:27
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#15
03.11.2022 13:40:05
Назар Скалат,  ещё одна бездумная цитата и я закрою тему!
С какой целью цитируете код? Какой в этом смысл?
Запомните: кнопка цитирования не для ответа!
 
 
 
#16
03.11.2022 13:46:54
Юрий М, извините, не так долго сижу на этом сайте, не знал.
 
 
 
#17
03.11.2022 13:55:29
Jack Famous, хорошо, устранил проблему, но только копируется 9/10 столбцов, можете сделать чтобы 10/10 копировалось?  
Изменено: Назар Скалат - 03.11.2022 13:59:56
 
 
 
#18
03.11.2022 15:15:57
Цитата
Назар Скалат: копируется 9/10 столбцов
мой косяк  :D
Поправил в #8
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#19
03.11.2022 15:43:19
Цитата
Юрий М написал:
Назар Скалат ,  ещё одна бездумная цитата и я закрою тему!
Бездумная, это мягко сказано
Цитирует мой код, говорит, что не работает, но моего кода в файле нет.
Ну и как после этого назвать Назар Скалат?
 
 
 
#20
03.11.2022 18:01:06
Извините, не так часто пишу здесь  :)  
 
 
 
#21
03.11.2022 18:02:48
Jack Famous, спасибо! Можно к вам обращаться на прямую если возникнут какие-то вопросы?
 
 
 
#22
03.11.2022 18:05:33
Назар Скалат, напрямую — очень дорого  :D
Пишите на форуме, оформляйте темы как положено и вам обязательно помогут  ;)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#23
03.11.2022 18:48:07
Jack Famous, все хорошо работает так-как надо, но мне после этого из этих столбцов нужно собрать данные там добавить, умножить, но после каждой новой вставки все исчезает.
 
 
 
#24
03.11.2022 20:37:15
Jack Famous, записал видео: https://www.youtube.com/watch?v=ZsPzU-3Mq44
Изменено: Назар Скалат - 03.11.2022 20:38:00
 
 
 
#25
03.11.2022 20:51:57
Назар Скалат, вас такими темпами быстро забанят
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#26
03.11.2022 20:54:09
Jack Famous, почему?
 
 
 
#27
03.11.2022 22:56:23
Назар Скалат, писать в личку после того, как я вас ответил = получить игнор на неопределенный срок
Удачи!
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
Страницы: 1
Наверх