Форум программистов [Powered by Invision Power Board]

Версия для печати темы
Нажмите сюда для просмотра этой темы в оригинальном формате

Форум программистов > Программирование, связанное с MS Office > Объеденение повторяющихся ячеек

Автор: Eland 23.5.2006, 09:33

Ребят, есть у кого скриптик для объеденения одинаковых ячеек в одну ?
Т.е.
Есть например столбец

Код


AAAA
AAAA
BBBB
CCCC
CCCC
BBBB

И вот ячейки, где за АААА следует АААА и где за СССС следует СССС должны быть объеденены в одну, т.е. должно получиться:

Код


АААА

BBBB
CCCC

BBBB

А если это возможно реализовать встроенными средствами офиса - объясните плз. smile

Автор: Artiom 23.5.2006, 10:42

Код


 Dim tmp As Variant
 Dim minN, maxN As Integer
 minN = 1   'начало диапазона для проверки
 maxN = 9   'конец диапазона
 tmp = Sheets("NameOfsheet").Range("E" & minN).Value
 For n = minN + 1 To maxN
    If Sheets("NameOfsheet").Range("E" & n).Value = tmp Then
        Sheets("NameOfsheet").Range("E" & n).Value = ""
    Else
        tmp = Sheets("NameOfsheet").Range("E" & n).Value
    End If
 Next

Вот например пройти как можно пройти по столбцу E.

Автор: Eland 23.5.2006, 13:27

Не, мне немного не это надо.
Там есть функция такая "Merge"
Надо, чтобы не просто удаляла записи, а соединяла ячейки.

Автор: Eland 23.5.2006, 15:08

В общем, вот что пока получилось:

Код


Sub DupsJoin()

Dim otkuda, j, dokuda
otkuda = 2  'Откуда
dokuda = 417 'Докуда

For i = otkuda To dokuda
    
If i > 1 Then
    For j = i To dokuda
    
        If Range("A" & j).Value <> Range("A" & i).Value Then
            Range("A" & i, "A" & j - 1).Merge
            i = j - 1
            Exit For
        End If
            
    Next j
End If

Next i
End Sub

Ещё бы убрать подтверждения и было бы совсем замечательно.
Кстати, никто не знает, как это сделать ?

Автор: Artiom 23.5.2006, 16:03

Код


SendKeys "{enter}"

Автор: Izuver 13.6.2006, 23:54

Мучила меня такая фигня. Попробуй это

Sub Объединение_ячеек()
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
A = Selection.Rows.Count
Cells(1, 2).EntireColumn.Insert
Cells(1, 2).EntireColumn.Insert
For i = 1 To A
If Cells(i, 1) <> Cells(i + 1, 1) Then
Cells(i, 2).FormulaR1C1 = "=ROW()"
Cells(i, 3).FormulaR1C1 = "=COUNTIF(C[-2],RC[-2])"
Columns("C:C").Copy
Columns("C:C").PasteSpecial Paste:=xlPasteValues
End If
Next i
Cells(i + 1, 2).FormulaR1C1 = "=ROW()"
j = 1
Do
Do While Cells(j, 3) = 1
j = j + 1
Loop
Cells(j, 2).End(xlDown).Select
Set x = Selection
Range(Cells(j, 1), Cells(x - 1, 1)).ClearContents
Range(Cells(j, 1), Cells(x, 1)).Merge
j = x + 1
        If x = A + 2 Then
        Exit Do
        End If
Loop
Columns("B:C").EntireColumn.Delete
End Sub