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

Вход

Регистрация

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

 

= Мир MS Excel/форматирование данных с помощью макроса - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » форматирование данных с помощью макроса (Макросы/Sub)
форматирование данных с помощью макроса
cj081 Дата: Пятница, 09.09.2016, 10:41 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация: 0 ±
Замечаний: 60% ±

Excel 2010
Помогите, есть образец данных (пример во вложении, данные повторяющиеся A1, A2 и так далее их много),
нужно снять объединение ячеек, и выстроить их в определенном порядке.
К сообщению приложен файл: object1.xlsm(17Kb)


Сообщение отредактировал cj081 - Пятница, 09.09.2016, 14:03
 
Ответить
СообщениеПомогите, есть образец данных (пример во вложении, данные повторяющиеся A1, A2 и так далее их много),
нужно снять объединение ячеек, и выстроить их в определенном порядке.

Автор - cj081
Дата добавления - 09.09.2016 в 10:41
buchlotnik Дата: Пятница, 09.09.2016, 12:23 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 2049
Репутация: 613 ±
Замечаний: 0% ±

2010, 2013, 2016 RUS / ENG
а на формулах нельзя?
Код
=ИНДЕКС($F$2:$F$45;СТРОКА(A1)*3-2)
К сообщению приложен файл: object1-1-.xlsx(11Kb)


платная помощь:
ЯД: 410012595572239; WM: 311017577133
buchlotnik@mail.ru
 
Ответить
Сообщениеа на формулах нельзя?
Код
=ИНДЕКС($F$2:$F$45;СТРОКА(A1)*3-2)

Автор - buchlotnik
Дата добавления - 09.09.2016 в 12:23
K-SerJC Дата: Пятница, 09.09.2016, 13:18 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 79
Репутация: 11 ±
Замечаний: 60% ±

Excel 2013
подойдет?
[vba]
Код

Sub Reform()
Dim r As Integer, str As String
r = ActiveCell.Row
Selection.UnMerge '
Cells(r, 2) = Cells(r, 1)
Cells(r, 1) = Cells(r, 6)
Cells(r, 3) = Cells(r + 1, 6)
Cells(r, 4) = Cells(r + 1, 1)
Cells(r, 5) = Cells(r, 7)
Cells(r, 6) = Cells(r + 1, 7)
Cells(r, 7) = Cells(r + 2, 7)
str = r + 1 & ":" & r + 2
Rows(str).Select
Selection.Delete

End Sub
[/vba]
К сообщению приложен файл: _object1.xlsm(16Kb)


Благими намерениями выстелена дорога в АД.
 
Ответить
Сообщениеподойдет?
[vba]
Код

Sub Reform()
Dim r As Integer, str As String
r = ActiveCell.Row
Selection.UnMerge '
Cells(r, 2) = Cells(r, 1)
Cells(r, 1) = Cells(r, 6)
Cells(r, 3) = Cells(r + 1, 6)
Cells(r, 4) = Cells(r + 1, 1)
Cells(r, 5) = Cells(r, 7)
Cells(r, 6) = Cells(r + 1, 7)
Cells(r, 7) = Cells(r + 2, 7)
str = r + 1 & ":" & r + 2
Rows(str).Select
Selection.Delete

End Sub
[/vba]

Автор - K-SerJC
Дата добавления - 09.09.2016 в 13:18
cj081 Дата: Пятница, 09.09.2016, 14:02 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация: 0 ±
Замечаний: 60% ±

Excel 2010
Формулами очень долго + надо снять объединение ячеек,

подойдет?

Спасибо, но немного не такой результат, наверно я плохо описал, прилагаю образец.
К сообщению приложен файл: -object1.xlsm(17Kb)
 
Ответить
СообщениеФормулами очень долго + надо снять объединение ячеек,

подойдет?

Спасибо, но немного не такой результат, наверно я плохо описал, прилагаю образец.

Автор - cj081
Дата добавления - 09.09.2016 в 14:02
KuklP Дата: Пятница, 09.09.2016, 15:31 | Сообщение № 5
Группа: Проверенные
Ранг: Старожил
Сообщений: 2006
Репутация: 436 ±
Замечаний: 20% ±

[vba]
Код
Public Sub www()
    Dim a, n&, i&
    a = [a2:j13].Value
    ReDim b(1 To UBound(a), 1 To UBound(a, 2))
    For i = 1 To UBound(a) Step 3
        n = n + 1
        b(n, 1) = a(i, 6): b(n, 2) = a(i, 1): b(n, 3) = a(i + 1, 1)
        b(n, 4) = a(i + 1, 6): b(n, 5) = a(i, 7): b(n, 6) = a(i + 1, 7): b(n, 7) = a(i + 2, 7)
        b(n, 8) = a(i, 8): b(n, 9) = a(i, 9): b(n, 10) = a(i, 10)
    Next
    [a2:j13].UnMerge: [a2:j13].ClearContents
    [a2].Resize(n, 10) = b
End Sub
[/vba]
К сообщению приложен файл: www.xls(64Kb)


Ну, с НДС и мы чего-то стoим! kuklp@mail.ru
WM Z206653985942, R334086032478, U238399322728
 
Ответить
Сообщение[vba]
Код
Public Sub www()
    Dim a, n&, i&
    a = [a2:j13].Value
    ReDim b(1 To UBound(a), 1 To UBound(a, 2))
    For i = 1 To UBound(a) Step 3
        n = n + 1
        b(n, 1) = a(i, 6): b(n, 2) = a(i, 1): b(n, 3) = a(i + 1, 1)
        b(n, 4) = a(i + 1, 6): b(n, 5) = a(i, 7): b(n, 6) = a(i + 1, 7): b(n, 7) = a(i + 2, 7)
        b(n, 8) = a(i, 8): b(n, 9) = a(i, 9): b(n, 10) = a(i, 10)
    Next
    [a2:j13].UnMerge: [a2:j13].ClearContents
    [a2].Resize(n, 10) = b
End Sub
[/vba]

Автор - KuklP
Дата добавления - 09.09.2016 в 15:31
cj081 Дата: Пятница, 09.09.2016, 16:05 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация: 0 ±
Замечаний: 60% ±

Excel 2010
Дата: Пятница, 09.09.2016, 15:31 | Сообщение № 5
Группа: Проверенные
Ранг: Старожил
Сообщений: 1943
Репутация: 405 ±
Замечаний: 0% ±

Public Sub www()
Dim a, n&, i&
a = [a2:j13].Value
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
For i = 1 To UBound(a) Step 3
n = n + 1
b(n, 1) = a(i, 6): b(n, 2) = a(i, 1): b(n, 3) = a(i + 1, 1)
b(n, 4) = a(i + 1, 6): b(n, 5) = a(i, 7): b(n, 6) = a(i + 1, 7): b(n, 7) = a(i + 2, 7)
b(n, 8) = a(i, 8): b(n, 9) = a(i, 9): b(n, 10) = a(i, 10)
Next
[a2:j13].UnMerge: [a2:j13].ClearContents
[a2].Resize(n, 10) = b
End Sub
Public Sub www()
Dim a, n&, i&
a = [a2:j13].Value
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
For i = 1 To UBound(a) Step 3
n = n + 1
b(n, 1) = a(i, 6): b(n, 2) = a(i, 1): b(n, 3) = a(i + 1, 1)
b(n, 4) = a(i + 1, 6): b(n, 5) = a(i, 7): b(n, 6) = a(i + 1, 7): b(n, 7) = a(i + 2, 7)
b(n, 8) = a(i, 8): b(n, 9) = a(i, 9): b(n, 10) = a(i, 10)
Next
[a2:j13].UnMerge: [a2:j13].ClearContents
[a2].Resize(n, 10) = b
End SubKuklP
К сообщению приложен файл: www.xls(64Kb)

[moder]Нарушение п. 5j Правил форума. 3-е замечание[/moder]

Не тот результат, вот сделал сам макрос, итог, но как бы сделать чтобы действовал на весь лист:
[vba]
Код

Sub Макрос4()
'
' Макрос4 Макрос
'

'
    Range("A1:J12").Select
    With Selection
        .VerticalAlignment = xlTop
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    Columns("A:B").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("H1").Select
    Selection.Cut
    Range("A1").Select
    ActiveSheet.Paste
    Range("H4").Select
    Selection.Cut
    Range("A4").Select
    ActiveSheet.Paste
    Range("H7").Select
    Selection.Cut
    Range("A7").Select
    ActiveSheet.Paste
    Range("H10").Select
    Selection.Cut
    Range("A10").Select
    ActiveSheet.Paste
    Range("C1").Select
    Selection.Cut
    Range("B1").Select
    ActiveSheet.Paste
    Range("C4").Select
    Selection.Cut
    Range("B4").Select
    ActiveSheet.Paste
    Range("C7").Select
    Selection.Cut
    Range("B7").Select
    ActiveSheet.Paste
    Range("C10").Select
    Selection.Cut
    Range("B10").Select
    ActiveSheet.Paste
    Range("C2").Select
    Selection.Cut
    Range("C1").Select
    ActiveSheet.Paste
    Range("C5").Select
    Selection.Cut
    Range("C4").Select
    ActiveSheet.Paste
    Range("C8").Select
    Selection.Cut
    Range("C7").Select
    ActiveSheet.Paste
    Range("C11").Select
    Selection.Cut
    Range("C10").Select
    ActiveSheet.Paste
    Columns("C:C").EntireColumn.AutoFit
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("I2:I11").Select
    Selection.Cut
    Range("C1").Select
    ActiveSheet.Paste
    Range("J1:J3").Select
    Selection.Copy
    Range("E1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Range("J4:J6").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("E4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Range("J7:J9").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("E7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Range("J10:J11").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("E10").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Columns("H:J").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Cells.Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$M$12").AutoFilter Field:=1, Criteria1:="="
    Rows("2:12").Select
    Selection.Delete Shift:=xlUp
    ActiveSheet.Range("$A$1:$M$4").AutoFilter Field:=1
    Selection.AutoFilter
    ActiveWorkbook.Save
    With Selection.Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    ActiveWorkbook.Save
End Sub
[/vba]


Сообщение отредактировал cj081 - Пятница, 09.09.2016, 16:06
 
Ответить
Сообщение
Дата: Пятница, 09.09.2016, 15:31 | Сообщение № 5
Группа: Проверенные
Ранг: Старожил
Сообщений: 1943
Репутация: 405 ±
Замечаний: 0% ±

Public Sub www()
Dim a, n&, i&
a = [a2:j13].Value
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
For i = 1 To UBound(a) Step 3
n = n + 1
b(n, 1) = a(i, 6): b(n, 2) = a(i, 1): b(n, 3) = a(i + 1, 1)
b(n, 4) = a(i + 1, 6): b(n, 5) = a(i, 7): b(n, 6) = a(i + 1, 7): b(n, 7) = a(i + 2, 7)
b(n, 8) = a(i, 8): b(n, 9) = a(i, 9): b(n, 10) = a(i, 10)
Next
[a2:j13].UnMerge: [a2:j13].ClearContents
[a2].Resize(n, 10) = b
End Sub
Public Sub www()
Dim a, n&, i&
a = [a2:j13].Value
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
For i = 1 To UBound(a) Step 3
n = n + 1
b(n, 1) = a(i, 6): b(n, 2) = a(i, 1): b(n, 3) = a(i + 1, 1)
b(n, 4) = a(i + 1, 6): b(n, 5) = a(i, 7): b(n, 6) = a(i + 1, 7): b(n, 7) = a(i + 2, 7)
b(n, 8) = a(i, 8): b(n, 9) = a(i, 9): b(n, 10) = a(i, 10)
Next
[a2:j13].UnMerge: [a2:j13].ClearContents
[a2].Resize(n, 10) = b
End SubKuklP
К сообщению приложен файл: www.xls(64Kb)

[moder]Нарушение п. 5j Правил форума. 3-е замечание[/moder]

Не тот результат, вот сделал сам макрос, итог, но как бы сделать чтобы действовал на весь лист:
[vba]
Код

Sub Макрос4()
'
' Макрос4 Макрос
'

'
    Range("A1:J12").Select
    With Selection
        .VerticalAlignment = xlTop
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    Columns("A:B").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("H1").Select
    Selection.Cut
    Range("A1").Select
    ActiveSheet.Paste
    Range("H4").Select
    Selection.Cut
    Range("A4").Select
    ActiveSheet.Paste
    Range("H7").Select
    Selection.Cut
    Range("A7").Select
    ActiveSheet.Paste
    Range("H10").Select
    Selection.Cut
    Range("A10").Select
    ActiveSheet.Paste
    Range("C1").Select
    Selection.Cut
    Range("B1").Select
    ActiveSheet.Paste
    Range("C4").Select
    Selection.Cut
    Range("B4").Select
    ActiveSheet.Paste
    Range("C7").Select
    Selection.Cut
    Range("B7").Select
    ActiveSheet.Paste
    Range("C10").Select
    Selection.Cut
    Range("B10").Select
    ActiveSheet.Paste
    Range("C2").Select
    Selection.Cut
    Range("C1").Select
    ActiveSheet.Paste
    Range("C5").Select
    Selection.Cut
    Range("C4").Select
    ActiveSheet.Paste
    Range("C8").Select
    Selection.Cut
    Range("C7").Select
    ActiveSheet.Paste
    Range("C11").Select
    Selection.Cut
    Range("C10").Select
    ActiveSheet.Paste
    Columns("C:C").EntireColumn.AutoFit
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("I2:I11").Select
    Selection.Cut
    Range("C1").Select
    ActiveSheet.Paste
    Range("J1:J3").Select
    Selection.Copy
    Range("E1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Range("J4:J6").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("E4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Range("J7:J9").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("E7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Range("J10:J11").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("E10").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Columns("H:J").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Cells.Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$M$12").AutoFilter Field:=1, Criteria1:="="
    Rows("2:12").Select
    Selection.Delete Shift:=xlUp
    ActiveSheet.Range("$A$1:$M$4").AutoFilter Field:=1
    Selection.AutoFilter
    ActiveWorkbook.Save
    With Selection.Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    ActiveWorkbook.Save
End Sub
[/vba]

Автор - cj081
Дата добавления - 09.09.2016 в 16:05
K-SerJC Дата: Пятница, 09.09.2016, 16:21 | Сообщение № 7
Группа: Пользователи
Ранг: Участник
Сообщений: 79
Репутация: 11 ±
Замечаний: 60% ±

Excel 2013

Спасибо, но немного не такой результат, наверно я плохо описал, прилагаю образец.

выделяешь ячейку А, запускаешь макрос
макрос когда находит подряд три пустых строки останавливается. или ограничение поставил 65535 строк
[vba]
Код
Sub Reform()
Dim r As Integer, str As String
r = ActiveCell.Row
Cells.Select
Selection.UnMerge
With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
NextRec:
Cells(r, 1).Activate
Cells(r, 2) = Cells(r, 1)
Cells(r, 1) = Cells(r, 6)
Cells(r, 3) = Cells(r + 1, 6)
Cells(r, 4) = Cells(r + 1, 1)
Cells(r, 5) = Cells(r, 7)
Cells(r, 6) = Cells(r + 1, 7)
Cells(r, 7) = Cells(r + 2, 7)
str = r + 1 & ":" & r + 2
Rows(str).Select
Selection.Delete
If (Cells(r + 1, 1) = "" And Cells((r + 2), 1) = "" And Cells((r + 3), 1) = "") Or r >= 65535 Then
Exit Sub
End If
r = r + 1
Cells(r, 1).Select
GoTo NextRec
End Sub
[/vba]


Благими намерениями выстелена дорога в АД.
 
Ответить
Сообщение

Спасибо, но немного не такой результат, наверно я плохо описал, прилагаю образец.

выделяешь ячейку А, запускаешь макрос
макрос когда находит подряд три пустых строки останавливается. или ограничение поставил 65535 строк
[vba]
Код
Sub Reform()
Dim r As Integer, str As String
r = ActiveCell.Row
Cells.Select
Selection.UnMerge
With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
NextRec:
Cells(r, 1).Activate
Cells(r, 2) = Cells(r, 1)
Cells(r, 1) = Cells(r, 6)
Cells(r, 3) = Cells(r + 1, 6)
Cells(r, 4) = Cells(r + 1, 1)
Cells(r, 5) = Cells(r, 7)
Cells(r, 6) = Cells(r + 1, 7)
Cells(r, 7) = Cells(r + 2, 7)
str = r + 1 & ":" & r + 2
Rows(str).Select
Selection.Delete
If (Cells(r + 1, 1) = "" And Cells((r + 2), 1) = "" And Cells((r + 3), 1) = "") Or r >= 65535 Then
Exit Sub
End If
r = r + 1
Cells(r, 1).Select
GoTo NextRec
End Sub
[/vba]

Автор - K-SerJC
Дата добавления - 09.09.2016 в 16:21
KuklP Дата: Пятница, 09.09.2016, 16:22 | Сообщение № 8
Группа: Проверенные
Ранг: Старожил
Сообщений: 2006
Репутация: 436 ±
Замечаний: 20% ±

сделал сам макрос

Ага, вот так сам взял и сделал :D cj081, что значит
Не тот результат
А ну укажите мне конкретные различия между верхней и нижней таблицами на рисунке. Правда пару цифер поменял, столбцы B и D в макросе.
[vba]
Код
Public Sub www()
    Dim a, n&, i&
    a = [a2:j13].Value
    ReDim b(1 To UBound(a), 1 To UBound(a, 2))
    For i = 1 To UBound(a) Step 3
        n = n + 1
        b(n, 1) = a(i, 6): b(n, 2) = a(i, 1): b(n, 4) = a(i + 1, 1)
        b(n, 3) = a(i + 1, 6): b(n, 5) = a(i, 7): b(n, 6) = a(i + 1, 7): b(n, 7) = a(i + 2, 7)
        b(n, 8) = a(i, 8): b(n, 9) = a(i, 9): b(n, 10) = a(i, 10)
    Next
    [a2:j13].UnMerge: [a2:j13].ClearContents
    [a2].Resize(n, 10) = b
End Sub
[/vba]
К сообщению приложен файл: 3728455.gif(19Kb)


Ну, с НДС и мы чего-то стoим! kuklp@mail.ru
WM Z206653985942, R334086032478, U238399322728


Сообщение отредактировал KuklP - Пятница, 09.09.2016, 16:24
 
Ответить
Сообщение
сделал сам макрос

Ага, вот так сам взял и сделал :D cj081, что значит
Не тот результат
А ну укажите мне конкретные различия между верхней и нижней таблицами на рисунке. Правда пару цифер поменял, столбцы B и D в макросе.
[vba]
Код
Public Sub www()
    Dim a, n&, i&
    a = [a2:j13].Value
    ReDim b(1 To UBound(a), 1 To UBound(a, 2))
    For i = 1 To UBound(a) Step 3
        n = n + 1
        b(n, 1) = a(i, 6): b(n, 2) = a(i, 1): b(n, 4) = a(i + 1, 1)
        b(n, 3) = a(i + 1, 6): b(n, 5) = a(i, 7): b(n, 6) = a(i + 1, 7): b(n, 7) = a(i + 2, 7)
        b(n, 8) = a(i, 8): b(n, 9) = a(i, 9): b(n, 10) = a(i, 10)
    Next
    [a2:j13].UnMerge: [a2:j13].ClearContents
    [a2].Resize(n, 10) = b
End Sub
[/vba]

Автор - KuklP
Дата добавления - 09.09.2016 в 16:22
Мир MS Excel » Вопросы и решения » Вопросы по VBA » форматирование данных с помощью макроса (Макросы/Sub)
Страница 1 из 11
Поиск:

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