0 / 0 / 1
Регистрация: 27.04.2016
Сообщений: 376
1

Макрос на объединение одинаковых ячеек не видит нули

06.12.2017, 18:08. Показов 1263. Ответов 17
Метки нет (Все метки)

Author24 — интернет-сервис помощи студентам
здравствуйте .
использую макрос для объединения одинаковых строк в первом столбце
Visual Basic
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
Sub q()
'
' q Макрос
'
' Сочетание клавиш: Ctrl+w
'
Dim i&, n&, arr, rn&
n = Cells(Rows.Count, 1).End(xlUp).Row + 1
 
Range("A1:A" & n - 1).MergeCells = False
For r = 2 To n - 1
    If Cells(r, 1) = "" Then Cells(r, 1) = Cells(r - 1, 1)
Next r
arr = Cells(1, 1).Resize(n)
rn = 1
Application.DisplayAlerts = False
For i = 2 To n
If arr(i, 1) <> arr(i - 1, 1) Then
With Range(Cells(rn, 1), Cells(i - 1, 1))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
rn = i
End If
Next
Application.DisplayAlerts = True
End Sub
когда макрос видит случай в столбики одни нули то объединения не происходит.
если присутствует хотя бы одно число с нулями всё нормально макрос обедняет строки.

и ещё вопрос. можно ли как то из delphi удалять все макросы активной книги excel
то есть это нужно чтобы при сохранение самого файла excel не выдавало что сохранить с макросами или без. просто сохранялась книга.
заранее благодарен

Добавлено через 6 минут
первый вопрос что сделать с макросом чтобы и с нулями (когда они одни) происходило такое обледенение
0
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
06.12.2017, 18:08
Ответы с готовыми решениями:

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

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

Макрос выделения диапазона ячеек-объединение их в одну-переход на след.строку-повтор пред.действия
Добрый день. Помогите плиз решить задачу. Я с VBA столкнулся впервые 1) в строке необходимо...

Объединение ячеек одного столбца при совпадении ячеек в другом
Здравствуйте, В таблице необходимо объединить все телефоны в одну ячейку, если совпадение по...

17
85 / 82 / 31
Регистрация: 13.10.2014
Сообщений: 167
07.12.2017, 03:03 2
Первые вопрос.
Пустые ячейки обязаны быть. Или добавьте обработку ошибки.
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
Sub q_1()
Application.DisplayAlerts = False
n = Cells(Rows.Count, 1).End(xlUp).Row + 1
With Range("A2:A" & n - 1)
.MergeCells = False
For Each x In .SpecialCells(4).Areas
x.Value = x.Cells(1).Offset(-1).Value
x.Offset(-1).Resize(x.Count + 1).MergeCells = True
Next x
End With
Application.DisplayAlerts = True
End Sub
1
0 / 0 / 1
Регистрация: 27.04.2016
Сообщений: 376
07.12.2017, 15:28  [ТС] 3
пустые ячейки не должны объединятся.
у меня
вот это
0
0
0
не объединяет
а когда
0
0
0
1
обьединяет

Добавлено через 54 секунды
в принципе столбик будет всегда заполнен.
только вот такой частный случай не работает

Добавлено через 6 часов 26 минут
k61, ваш макрос выдаёт ошибку 400
0
1846 / 1161 / 354
Регистрация: 11.07.2014
Сообщений: 4,102
08.12.2017, 09:29 4
pek, ваша пустая n+1 ячейка тоже при сравнении воспринимается как ноль
Если подправить ваш оператор, то всё будет Ок

Visual Basic
1
If arr(i, 1) <> arr(i - 1, 1) Or arr(i, 1) = "" Then
Добавлено через 44 минуты
pek, ну если уж записать совсем корректно, то ваш код внутри цикла записать так:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
If arr(i - 1, 1) = "" And i = 2 Then
  rn = 2
Else
  If arr(i, 1) <> arr(i - 1, 1) Or arr(i, 1) = "" Then
    With Range(Cells(rn, 1), Cells(i - 1, 1))
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .WrapText = False
      .Orientation = 0
      .AddIndent = False
      .IndentLevel = 0
      .ShrinkToFit = False
      .ReadingOrder = xlContext
      .MergeCells = True
      If arr(i, 1) = "" Then i = i + 1
    End With
    rn = i
  End If
End If
1
0 / 0 / 1
Регистрация: 27.04.2016
Сообщений: 376
09.12.2017, 08:20  [ТС] 5
сделал вот так всё работает хорошо
но вот загвоздка такая
дописал код на стирание всех макросов
и получается такая история
я выгружаю с delphi в шаблон с макросом
выгрузка ещё не закончилась а макрос уже убит
Visual Basic
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
44
45
46
47
48
49
50
51
52
53
54
Sub q()
'
 
'
Dim i&, n&, arr, rn&
n = Cells(Rows.Count, 1).End(xlUp).Row + 1
 
Range("A1:A" & n - 1).MergeCells = False
For r = 2 To n - 1
    If Cells(r, 1) = "" Then Cells(r, 1) = Cells(r - 1, 1)
Next r
arr = Cells(1, 1).Resize(n)
rn = 1
Application.DisplayAlerts = False
For i = 2 To n
If arr(i - 1, 1) = "" And i = 2 Then
  rn = 2
Else
  If arr(i, 1) <> arr(i - 1, 1) Or arr(i, 1) = "" Then
    With Range(Cells(rn, 1), Cells(i - 1, 1))
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .WrapText = False
      .Orientation = 0
      .AddIndent = False
      .IndentLevel = 0
      .ShrinkToFit = False
      .ReadingOrder = xlContext
      .MergeCells = True
      If arr(i, 1) = "" Then i = i + 1
    End With
    rn = i
  End If
End If
Next
Application.DisplayAlerts = True
 
' -------------------------------------
' здесь удаление всех макросов
    Dim vc As Object
    
    With ActiveWorkbook.VBProject
        For Each vc In .VBComponents
            If vc.Type <> 100 Then
                .VBComponents.Remove vc
            End If
        Next vc
        For Each vc In .VBComponents
            vc.CodeModule.DeleteLines 1, vc.CodeModule.CountOfLines
        Next vc
    End With
 
 
End Sub
подскажите как сделать чтобы чтобы этот макрос состоящий из двух частей
срабатывал относительно выгрузки из delphi то есть когда выгрузка прошла полностью тогда запускался макрос.
да точно нужен макрос который определяет когда заканчивается экспорт в активную книгу и запускает следующий макрос--мой

Добавлено через 2 часа 22 минуты
да точно нужен макрос который определяет когда заканчивается экспорт в активную книгу и запускает следующий макрос--мой
разобрался

подскажите как макрос дописать для столбика B ваще пе получается
0
0 / 0 / 1
Регистрация: 27.04.2016
Сообщений: 376
13.12.2017, 07:16  [ТС] 6
подскажите как доделать мой макрос чтобы объединение третьего столбца было как в первом
Миниатюры
Макрос на объединение одинаковых ячеек не видит нули  
0
85 / 82 / 31
Регистрация: 13.10.2014
Сообщений: 167
13.12.2017, 07:28 7
Формат первого столба скопируйте в третий.
1
0 / 0 / 1
Регистрация: 27.04.2016
Сообщений: 376
13.12.2017, 07:30  [ТС] 8
можно поподробней
0
85 / 82 / 31
Регистрация: 13.10.2014
Сообщений: 167
13.12.2017, 10:47 9
Цитата Сообщение от pek Посмотреть сообщение
можно поподробней
Без вашего примера, подробнее не получится:
Visual Basic
1
2
3
Columns(1).Copy
Columns(3).PasteSpecial Paste:=4
Application.CutCopyMode = False
1
0 / 0 / 1
Регистрация: 27.04.2016
Сообщений: 376
14.12.2017, 06:28  [ТС] 10
я сделал
Delphi
1
Range("A3:A" & n - 1).Copy Destination:=Range("C3:C" & n - 1)
Добавлено через 19 часов 39 минут
блин не получается это у меня диапазон копируется
то есть копирование того же самого из первого столбика в третий
мне только нужно форматирование.

как у k61, не получается тоже не коректно
0
0 / 0 / 1
Регистрация: 27.04.2016
Сообщений: 376
14.12.2017, 06:43  [ТС] 11
попробовал сделать вот так
Visual Basic
1
2
 Range("A3:A" & n - 1).Copy
 Range("C3:C" & n - 1).PasteSpecial xlPasteFormats
вроде всё нормально
только в третьем столбике происходит объединение с заполненой первой ячейкой а все последующие пустые
Вложения
Тип файла: xlsx Книга1.xlsx (14.1 Кб, 7 просмотров)
0
0 / 0 / 1
Регистрация: 27.04.2016
Сообщений: 376
14.12.2017, 06:46  [ТС] 12
вот сам макрос
Visual Basic
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
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
Sub q()
Dim i&, n&, arr, rn&
n = Cells(Rows.Count, 1).End(xlUp).Row + 1
 
Range("A3:A" & n - 1).MergeCells = False
For r = 2 To n - 1
    If Cells(r, 1) = "" Then Cells(r, 1) = Cells(r - 1, 1)
Next r
arr = Cells(1, 1).Resize(n)
rn = 1
Application.DisplayAlerts = False
For i = 2 To n
If arr(i - 1, 1) = "" And i = 2 Then
  rn = 2
Else
  If arr(i, 1) <> arr(i - 1, 1) Or arr(i, 1) = "" Then
    With Range(Cells(rn, 1), Cells(i - 1, 1))
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .WrapText = False
      .Orientation = 0
      .AddIndent = False
      .IndentLevel = 0
      .ShrinkToFit = False
      .ReadingOrder = xlContext
      .MergeCells = True
      If arr(i, 1) = "" Then i = i + 1
    End With
    rn = i
  End If
End If
Next
Application.DisplayAlerts = True
'----------------------------------
 
Dim i1&, n1&, arr1, rn1&
n1 = Cells(Rows.Count, 2).End(xlUp).Row + 1
 
Range("B3:B" & n1 - 1).MergeCells = False
For r1 = 2 To n1 - 1
    If Cells(r1, 2) = "" Then Cells(r1, 2) = Cells(r1 - 1, 2)
Next r1
arr1 = Cells(1, 2).Resize(n1)
rn1 = 1
Application.DisplayAlerts = False
For i1 = 2 To n
If arr1(i1 - 1, 1) = "" And i1 = 2 Then
  rn1 = 2
Else
  If arr1(i1, 1) <> arr1(i1 - 1, 1) Or arr1(i1, 1) = "" Then
    With Range(Cells(rn1, 2), Cells(i1 - 1, 2))
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .WrapText = False
      .Orientation = 0
      .AddIndent = False
      .IndentLevel = 0
      .ShrinkToFit = False
      .ReadingOrder = xlContext
      .MergeCells = True
      If arr1(i1, 1) = "" Then i1 = i1 + 1
    End With
    rn1 = i1
  End If
End If
Next
Application.DisplayAlerts = True
'----------------------------
 
Dim i2&, n2&, arr2, rn2&
n2 = Cells(Rows.Count, 3).End(xlUp).Row + 1
 
Range("C3:C" & n2 - 1).MergeCells = False
For r2 = 2 To n2 - 1
    If Cells(r2, 3) = "" Then Cells(r2, 3) = Cells(r2 - 1, 3)
Next r2
arr2 = Cells(1, 3).Resize(n2)
rn2 = 1
Application.DisplayAlerts = False
For i2 = 2 To n
If arr2(i2 - 1, 1) = "" And i2 = 2 Then
  rn2 = 2
Else
  If arr2(i2, 1) <> arr2(i2 - 1, 1) Or arr2(i2, 1) = "" Then
    With Range(Cells(rn2, 3), Cells(i2 - 1, 3))
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .WrapText = False
      .Orientation = 0
      .AddIndent = False
      .IndentLevel = 0
      .ShrinkToFit = False
      .ReadingOrder = xlContext
      .MergeCells = True
      If arr2(i2, 1) = "" Then i2 = i2 + 1
    End With
    rn2 = i2
  End If
End If
Next
Application.DisplayAlerts = True
'------------------------------------
Range("A3:A" & n - 1).Copy Destination:=Range("C3:C" & n - 1)
End Sub
0
85 / 82 / 31
Регистрация: 13.10.2014
Сообщений: 167
14.12.2017, 07:51 13
Код копирования формата из сообщения #9 рабочий.
Всё бы у нас так работало.
В процедуре из сообщения #12 ошибка возникает в 50-й строке, где вы пытаетесь обратиться к несуществующему элементу массива при значении счётчика цикла i1=3.
Или вы приложили некорректный пример.
1
0 / 0 / 1
Регистрация: 27.04.2016
Сообщений: 376
14.12.2017, 07:55  [ТС] 14
Код копирования формата из сообщения #9 рабочий.
Всё бы у нас так работало.
в принципе работает
но мне надо с третей строки начинать а не весь столбик брать
как начать с третьей строки?
Или вы приложили некорректный пример.
это просто пример как должно быть а не в тот в каком работаю
0
85 / 82 / 31
Регистрация: 13.10.2014
Сообщений: 167
14.12.2017, 08:22 15
И с третьей строки работает:
Visual Basic
1
2
3
Range("A3:A" & n - 1).Copy
Range("C3:C" & n - 1).PasteSpecial Paste:=4
Application.CutCopyMode = False
Облегчённый пример:
Вложения
Тип файла: xls Упрощённый_пример_Pek.xls (49.5 Кб, 7 просмотров)
1
0 / 0 / 1
Регистрация: 27.04.2016
Сообщений: 376
14.12.2017, 09:24  [ТС] 16
Paste:=4 это получается конкретно для 4 строк
но каждый раз может разное число строк
или для чего это

Добавлено через 19 минут
не получается по вашему примеру
также пустая ячейка с права с низу
0
85 / 82 / 31
Регистрация: 13.10.2014
Сообщений: 167
14.12.2017, 09:48 17
у вас количество строк тут => (n - 1 ),
а 4 это xlPasteFormats (краткая запись).
1
0 / 0 / 1
Регистрация: 27.04.2016
Сообщений: 376
14.12.2017, 12:40  [ТС] 18
посмотрите . так и не хочет объединять .
внизу с права ячейка пустая . должна быть тоже 3
Вложения
Тип файла: xls Упрощённый_пример_Pek1.xls (73.5 Кб, 7 просмотров)
0
14.12.2017, 12:40
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
14.12.2017, 12:40
Помогаю со студенческими работами здесь

Макрос для пересчета взаимозависимых ячеек ячеек
Добрый вечер, уважаемые форумчане. Помогите, пожалуйста, реализовать следующую задачу. Имеется 2...

Объединение ячеек
Добрый день. Возник вопрос, как объединить ячейки в GoogleDocs, с переносом данных внутри самой...

Объединение ячеек
Запутался в объединении ячеек, подскажите. должно быть так рисунок текст 1 текст 2 Рисунок ...

Объединение ячеек
Добрый день, формучане) Помогите пожалуйста с макросом. Нужно объединить ячейки в сформировавшемся...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
18
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin
Copyright ©2000 - 2024, CyberForum.ru