Посчитать количество ТОЧЕК в ячейках - Microsoft Office Excel - Страница 2

lilpop · 10.09.2020, 11:28

Elixi,
не получилось
прикладываю файлы
в экселе показано как должно все выглядеть после копирования с Лист1 на Лист2
в ворде сам код, который использую
если запустить его еще раз, то не вставляются значения ниже на первую пустую строчку после какого-либо текста

Elixi · 10.09.2020, 18:08

lilpop,
Если пoнял правильнo, из стoлбца "наименoвание", пoпадают:
в 1 урoвень:
- Магазин
- Ларек
вo 2 урoвень:
- Первый магаыин
- Мини
- Бтoрoй ларек
- Мини 2
всё oстальнoе - тoвар

Исхoдные данные дoстатoчнo грязные чтoбы делать какoй-тo универсальный кoд.

На данные, кoтoрые в примере сделать кoд мoжнo:
услoвия для пoпадания в 1 урoвень:
- в стoлбце № п/п значения сoдержат не бoлее двух тoчек и не бoлее двух цифр,
- в стoлбце "наименoвание" шрифт тoлстый
услoвия для пoпадания вo 2 урoвень:
- в стoлбце № п/п значения сoдержат не бoлее трёх тoчек, не бoлее четырёх цифр,
- в стoлбце "наименoвание" шрифт тoлстый

Нo есть пoдoзрение, чтo этo тoлькo пример, чтo данных намнoгo бoльше и на них этo рабoтаь уже не будет.
Вoзмoжнo, существует списoк названий пo кoтoрoму былo бы мoжнo oпределить принадлежнoсть к первoму или втoрoму урoвню?

lilpop · 10.09.2020, 18:50

Elixi,
основная задача переноса по количеству точек после того, как уберется последний знак

Код:

Sub убратьЗнаки()
  Dim r As Long, v As String
  For i = 11 To Cells(Rows.Count, 1).End(xlUp).Row
    v = CStr(Cells(i, 1).Value)
    If v <> "" Then Cells(i, 4).Value = Left(v, Len(v) - 1)
    Next
End Sub

а затем уже, исходя из того, сколько точек есть - переносятся данные из столбца "В" листа 1 в лист 2

Код:

Sub Уровень1()
With Sheets(1)
        For i = 11 To Sheets("Лист1").Cells(Rows.Count, 4).End(xlUp).Row
            TK = Len(Sheets("Лист1").Cells(i, 4).Value) - Len(Replace(Sheets("Лист1").Cells(i, 4).Value, ",", ""))
            Select Case TK
                Case Is = 1
                    Sheets("Лист2").Cells(i - 6, 2) = Sheets("Лист1").Cells(i, 2).Value
            End Select
        Next i
End With
End Sub


Sub остальныеУровни()
With Sheets(1)
        For i = 11 To Sheets("Лист1").Cells(Rows.Count, 4).End(xlUp).Row
            TK = Len(Sheets("Лист1").Cells(i, 4).Value) - Len(Replace(Sheets("Лист1").Cells(i, 4).Value, ".", ""))
            Select Case TK
                Case Is = 2
                    Sheets("Лист2").Cells(i - 6, 3) = Sheets("Лист1").Cells(i, 2).Value
                Case Is = 3
                    Sheets("Лист2").Cells(i - 6, 4) = Sheets("Лист1").Cells(i, 2).Value
                Case Is = 4
                    Sheets("Лист2").Cells(i - 6, 5) = Sheets("Лист1").Cells(i, 2).Value
                Case Is = 5
                    Sheets("Лист2").Cells(i - 6, 6) = Sheets("Лист1").Cells(i, 2).Value
                Case Is = 6
                    Sheets("Лист2").Cells(i - 6, 7) = Sheets("Лист1").Cells(i, 2).Value
            End Select
        Next i
    End With
End Sub

Sub растягивание()
Dim i&
Dim N&
 For N = 2 To 3 'столбцы
        For i = 5 To Sheets("Лист2").Cells(Rows.Count, 4).End(xlUp).Row
            If Sheets("Лист2").Cells(i, N).Value = "" Then
                Sheets("Лист2").Cells(i, N) = Sheets("Лист2").Cells(i - 1, N)
            End If
        Next i
    Next N
End Sub

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

Elixi · 10.09.2020, 21:02

так будет правильно?
попробуйте запустить макрос Sub ИТОГ() в Module2

lilpop · 10.09.2020, 21:17

Elixi,
в модуле 2 нет итога (все прокрутила)
там есть
Sub ____()
Call ___________
'Call _______1
Call _______________
Call ____________
End Sub

и все подсвечено красным

Elixi · 10.09.2020, 21:36

Цитата:

Сообщение от lilpop

Elixi,
в модуле 2 нет итога (все прокрутила)

???????
там должно быть это:

Код:

'   у меня не работают макросы в которых названия листов русскими буквами
'   так что здесь я названия поменял с Sheets("Лист1") на Sheets(1) и аналогично Sheets("Лист2") на Sheets(2)
'   вы можете поменять обратно (функция Replace, <CTRL H>):
'   Replace: Sheets(1) на Sheets("Лист1")
'   Replace: Sheets(2) на Sheets("Лист2")

Sub ИТОГ()
    Call убратьЗнаки
    'Call Уровень1
    Call остальныеУровни
    Call растягивание
End Sub


Sub убратьЗнаки()
  Dim r As Long, v As String, i As Long
  For i = 11 To Cells(Rows.Count, 1).End(xlUp).Row
    v = CStr(Cells(i, 1).Value)
    If v <> "" Then
        Cells(i, 4).NumberFormat = "@"              'формат текст, так что точка должна вставиться в ячейку
        Cells(i, 4).Value = Left(v, Len(v) - 1)
    End If
    Next
End Sub


Sub Уровень1()
Dim i As Long
'With Sheets(1)
        For i = 11 To Sheets(1).Cells(Rows.Count, 4).End(xlUp).Row
            TK = Len(Sheets(1).Cells(i, 4).Value) - Len(Replace(Sheets(1).Cells(i, 4).Value, ",", ""))
            Select Case TK
                Case Is = 1
                    Sheets(2).Cells(i - 6, 2) = Sheets(1).Cells(i, 2).Value
            End Select
        Next i
'End With
End Sub


Sub остальныеУровни()
Dim i As Long
Dim TK As Integer
'With Sheets(1)
        For i = 11 To Sheets(1).Cells(Rows.Count, 4).End(xlUp).Row
            TK = Len(Sheets(1).Cells(i, 4).Value) - Len(Replace(Sheets(1).Cells(i, 4).Value, ".", ""))
            Select Case TK
                Case Is = 1
                    Sheets(2).Cells(i - 6, 2) = Sheets(1).Cells(i, 2).Value
                Case Is = 2
                    Sheets(2).Cells(i - 6, 3) = Sheets(1).Cells(i, 2).Value
                Case Is = 3
                    Sheets(2).Cells(i - 6, 4) = Sheets(1).Cells(i, 2).Value
                Case Is = 4
                    Sheets(2).Cells(i - 6, 5) = Sheets(1).Cells(i, 2).Value
                Case Is = 5
                    Sheets(2).Cells(i - 6, 6) = Sheets(1).Cells(i, 2).Value
                Case Is = 6
                    Sheets(2).Cells(i - 6, 7) = Sheets(1).Cells(i, 2).Value
            End Select
        Next i
'End With
End Sub


Sub растягивание()
Dim i&
Dim N&
 For N = 2 To 3 'столбцы
        For i = 6 To Sheets(2).Cells(Rows.Count, 4).End(xlUp).Row
            If Sheets(2).Cells(i, N).Value = "" Then
                Sheets(2).Cells(i, N) = Sheets(2).Cells(i - 1, N)
            End If
        Next i
    Next N
End Sub

lilpop · 10.09.2020, 21:46

Elixi,
очень странно, но такого нет
(я делаю на маке, видимо из-за несовместимости макросов на винде и маке)
сейчас попробую сделать

lilpop · 10.09.2020, 21:50

lilpop,
второй раз не вставляется снизу после в пустую строчку, но спасибо большое, что после удаления одного символа стоит точка!

Elixi · 10.09.2020, 22:10

Цитата:

Сообщение от lilpop

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

не понимаю что за второй раз
если запустите макрос второй раз, данные перепишутся, там ведь в процедуре Sub остальныеУровни(), привязка к тем же строкам что в исхиднике (переменная i),только вставляются на шесть строк выше:
Sheets(2).Cells(i - 6, 2) = Sheets(1).Cells(i, 2).Value

lilpop · 10.09.2020, 22:24

Elixi,
чтобы не перезаписывались в те же строчки, а вставлялись снизу (после первой процедуры) в новую пустую строчку (в файле это 69 строчка)
планируется в лист2 копировать несколько листов, и чтобы скопированные данные шли дальше, а не вставлялись в те же строчки
извините, если неправильно сформулировала вопрос

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Посчитать суммы из одних ячеек, если в соответствующих ячейках определенное значение	Нарилия	Microsoft Office Excel	3	28.02.2018 18:03
Среди трех точек с координатами (x1,y1), (x2,y2), (x3,y3) определить количество точек, лежащих во второй четверти и вывести на экран их координаты.	Viktoria_	Паскаль, Turbo Pascal, PascalABC.NET	3	20.02.2018 00:07
Как посчитать сумму в ячейках определенного цвета	vitek090283	Microsoft Office Excel	4	10.10.2017 02:14
Задаnm n точек. Найти m=3,4... точек и построить на них m-угольник: количество точек , лежащих внутри и вне его мин. различается	L.Rain	Помощь студентам	0	11.12.2011 22:19
Определить количество точек	Артур22	Общие вопросы Delphi	17	21.02.2011 11:09

10.09.2020, 18:08	#12
Elixi Форумчанин Регистрация: 10.05.2019 Сообщений: 172	lilpop, Если пoнял правильнo, из стoлбца "наименoвание", пoпадают: в 1 урoвень: - Магазин - Ларек вo 2 урoвень: - Первый магаыин - Мини - Бтoрoй ларек - Мини 2 всё oстальнoе - тoвар Исхoдные данные дoстатoчнo грязные чтoбы делать какoй-тo универсальный кoд. На данные, кoтoрые в примере сделать кoд мoжнo: услoвия для пoпадания в 1 урoвень: - в стoлбце № п/п значения сoдержат не бoлее двух тoчек и не бoлее двух цифр, - в стoлбце "наименoвание" шрифт тoлстый услoвия для пoпадания вo 2 урoвень: - в стoлбце № п/п значения сoдержат не бoлее трёх тoчек, не бoлее четырёх цифр, - в стoлбце "наименoвание" шрифт тoлстый Нo есть пoдoзрение, чтo этo тoлькo пример, чтo данных намнoгo бoльше и на них этo рабoтаь уже не будет. Вoзмoжнo, существует списoк названий пo кoтoрoму былo бы мoжнo oпределить принадлежнoсть к первoму или втoрoму урoвню?

10.09.2020, 21:17	#15
lilpop Пользователь Регистрация: 06.09.2020 Сообщений: 17	Elixi, в модуле 2 нет итога (все прокрутила) там есть Sub ____() Call ___________ 'Call _______1 Call _______________ Call ____________ End Sub и все подсвечено красным

10.09.2020, 21:46	#17
lilpop Пользователь Регистрация: 06.09.2020 Сообщений: 17	Elixi, очень странно, но такого нет (я делаю на маке, видимо из-за несовместимости макросов на винде и маке) сейчас попробую сделать

10.09.2020, 21:50	#18
lilpop Пользователь Регистрация: 06.09.2020 Сообщений: 17	lilpop, второй раз не вставляется снизу после в пустую строчку, но спасибо большое, что после удаления одного символа стоит точка!

10.09.2020, 22:24	#20
lilpop Пользователь Регистрация: 06.09.2020 Сообщений: 17	Elixi, чтобы не перезаписывались в те же строчки, а вставлялись снизу (после первой процедуры) в новую пустую строчку (в файле это 69 строчка) планируется в лист2 копировать несколько листов, и чтобы скопированные данные шли дальше, а не вставлялись в те же строчки извините, если неправильно сформулировала вопрос