форматирование данных с помощью макроса
cj081
Дата: Пятница, 09.09.2016, 10:41 |
Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация:
0
±
Замечаний:
60% ±
Excel 2010
Помогите, есть образец данных (пример во вложении, данные повторяющиеся A1, A2 и так далее их много), нужно снять объединение ячеек, и выстроить их в определенном порядке.
Помогите, есть образец данных (пример во вложении, данные повторяющиеся A1, A2 и так далее их много), нужно снять объединение ячеек, и выстроить их в определенном порядке. cj081
Сообщение отредактировал cj081 - Пятница, 09.09.2016, 14:03
Ответить
Сообщение Помогите, есть образец данных (пример во вложении, данные повторяющиеся A1, A2 и так далее их много), нужно снять объединение ячеек, и выстроить их в определенном порядке. Автор - cj081 Дата добавления - 09.09.2016 в 10:41
buchlotnik
Дата: Пятница, 09.09.2016, 12:23 |
Сообщение № 2
Группа: Заблокированные
Ранг: Участник клуба
Сообщений: 3442
Репутация:
929
±
Замечаний:
20% ±
2010, 2013, 2016 RUS / ENG
а на формулах нельзя? Код
=ИНДЕКС($F$2:$F$45;СТРОКА(A1)*3-2)
а на формулах нельзя? Код
=ИНДЕКС($F$2:$F$45;СТРОКА(A1)*3-2)
buchlotnik
Ответить
Сообщение а на формулах нельзя? Код
=ИНДЕКС($F$2:$F$45;СТРОКА(A1)*3-2)
Автор - buchlotnik Дата добавления - 09.09.2016 в 12:23
K-SerJC
Дата: Пятница, 09.09.2016, 13:18 |
Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 487
Репутация:
86
±
Замечаний:
0% ±
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]
подойдет? [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
Благими намерениями выстелена дорога в АД.
Ответить
Сообщение подойдет? [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
Формулами очень долго + надо снять объединение ячеек, Спасибо, но немного не такой результат, наверно я плохо описал, прилагаю образец.
Формулами очень долго + надо снять объединение ячеек, Спасибо, но немного не такой результат, наверно я плохо описал, прилагаю образец. cj081
Ответить
Сообщение Формулами очень долго + надо снять объединение ячеек, Спасибо, но немного не такой результат, наверно я плохо описал, прилагаю образец. Автор - cj081 Дата добавления - 09.09.2016 в 14:02
KuklP
Дата: Пятница, 09.09.2016, 15:31 |
Сообщение № 5
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация:
486
±
Замечаний:
0% ±
2003-2010
[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]
[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
К сообщению приложен файл:
www.xls
(63.5 Kb)
Ну с НДС и мы чего-то стoим! kuklp60@gmail.com 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]
Дата: Пятница, 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
Сообщение отредактировал 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
Группа: Проверенные
Ранг: Обитатель
Сообщений: 487
Репутация:
86
±
Замечаний:
0% ±
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
Благими намерениями выстелена дорога в АД.
Ответить
Сообщение Спасибо, но немного не такой результат, наверно я плохо описал, прилагаю образец.
выделяешь ячейку А, запускаешь макрос макрос когда находит подряд три пустых строки останавливается. или ограничение поставил 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
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация:
486
±
Замечаний:
0% ±
2003-2010
Ага, вот так сам взял и сделал 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]
Ага, вот так сам взял и сделал 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
Ну с НДС и мы чего-то стoим! kuklp60@gmail.com WM Z206653985942, R334086032478, U238399322728
Сообщение отредактировал KuklP - Пятница, 09.09.2016, 16:24
Ответить
Сообщение Ага, вот так сам взял и сделал 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