Помогите с макросом. Имеется сводный прайс лист, где в каждую ячейку строки занесено название товара состоящее из нескольких слов. Иногда из трех, иногда из четырех. Плюс добавлена цена и количество. В интернете нашел макрос, который объединяет текст в ячейках, но он объединяет все выбранные ячейки без разбора на строки. Чего хочется - выделить три столбца и две строки и чтобы произошло объединение столбцов построчно. В прилагаемом файле на листе 1 исходные данные, лист2 то что надо получить.
Помогите с макросом. Имеется сводный прайс лист, где в каждую ячейку строки занесено название товара состоящее из нескольких слов. Иногда из трех, иногда из четырех. Плюс добавлена цена и количество. В интернете нашел макрос, который объединяет текст в ячейках, но он объединяет все выбранные ячейки без разбора на строки. Чего хочется - выделить три столбца и две строки и чтобы произошло объединение столбцов построчно. В прилагаемом файле на листе 1 исходные данные, лист2 то что надо получить.Wander
Sub MergeToOneCell() Const sDELIM As String = " " 'символ-разделитель Dim rCell As Range Dim sMergeStr As String If TypeName(Selection) <> "Range" Then Exit Sub 'если выделены не ячейки - выходим With Selection For i = 1 To .Rows.Count For c = 1 To .Columns.Count sMergeStr = sMergeStr & sDELIM & .Cells(i, c).Value Next Application.DisplayAlerts = False .Cells(i, 1).Resize(1, .Columns.Count).Merge Across:=False Application.DisplayAlerts = True .Cells(i, 1) = Trim(sMergeStr) Next End With End Sub
[/vba]
Выделяете и запускаете: [vba]
Код
Sub MergeToOneCell() Const sDELIM As String = " " 'символ-разделитель Dim rCell As Range Dim sMergeStr As String If TypeName(Selection) <> "Range" Then Exit Sub 'если выделены не ячейки - выходим With Selection For i = 1 To .Rows.Count For c = 1 To .Columns.Count sMergeStr = sMergeStr & sDELIM & .Cells(i, c).Value Next Application.DisplayAlerts = False .Cells(i, 1).Resize(1, .Columns.Count).Merge Across:=False Application.DisplayAlerts = True .Cells(i, 1) = Trim(sMergeStr) Next End With End Sub
Sub MergeToOneCell() Const sDELIM As String = " " 'символ-разделитель Dim rCell As Range Dim sMergeStr As String If TypeName(Selection) <> "Range" Then Exit Sub 'если выделены не ячейки - выходим With Selection For i = 1 To .Rows.Count sMergeStr = "" For c = 1 To .Columns.Count sMergeStr = sMergeStr & sDELIM & .Cells(i, c).Value Next Application.DisplayAlerts = False .Cells(i, 1).Resize(1, .Columns.Count).Merge Across:=False Application.DisplayAlerts = True .Cells(i, 1) = Trim(sMergeStr) Next End With End Sub
[/vba]
[vba]
Код
Sub MergeToOneCell() Const sDELIM As String = " " 'символ-разделитель Dim rCell As Range Dim sMergeStr As String If TypeName(Selection) <> "Range" Then Exit Sub 'если выделены не ячейки - выходим With Selection For i = 1 To .Rows.Count sMergeStr = "" For c = 1 To .Columns.Count sMergeStr = sMergeStr & sDELIM & .Cells(i, c).Value Next Application.DisplayAlerts = False .Cells(i, 1).Resize(1, .Columns.Count).Merge Across:=False Application.DisplayAlerts = True .Cells(i, 1) = Trim(sMergeStr) Next End With End Sub
Wander, а обязательно ячейки именно объединять? Может вам такой вариант подойдет? [vba]
Код
Sub JoinVal() Dim rng As Range, cell As Range, wsh As Worksheet 10 On Error GoTo err 20 With Application 30 .ScreenUpdating = 0: .EnableEvents = 0 40 Set wsh = ThisWorkbook.Worksheets("Лист1") 50 Set rng = Intersect(wsh.UsedRange, wsh.[A:A]) 60 For Each cell In rng.Cells 70 cell.Value = Trim(Join(.Index(wsh.Range(cell, cell.Offset(, _ 2)).Value, 1, 0), " ")) 80 Next 90 wsh.[B:C].EntireColumn.Delete: rng.EntireColumn.AutoFit 100 err: If err.Number Then 110 MsgBox "Ошибка " & err.Number & " (" & err.Description & _ ") в процедуре JoinVal модуля Module1 на строке " & Erl 120 End If 130 .ScreenUpdating = 1: .EnableEvents = 1 140 End With End Sub
[/vba]
Wander, а обязательно ячейки именно объединять? Может вам такой вариант подойдет? [vba]
Код
Sub JoinVal() Dim rng As Range, cell As Range, wsh As Worksheet 10 On Error GoTo err 20 With Application 30 .ScreenUpdating = 0: .EnableEvents = 0 40 Set wsh = ThisWorkbook.Worksheets("Лист1") 50 Set rng = Intersect(wsh.UsedRange, wsh.[A:A]) 60 For Each cell In rng.Cells 70 cell.Value = Trim(Join(.Index(wsh.Range(cell, cell.Offset(, _ 2)).Value, 1, 0), " ")) 80 Next 90 wsh.[B:C].EntireColumn.Delete: rng.EntireColumn.AutoFit 100 err: If err.Number Then 110 MsgBox "Ошибка " & err.Number & " (" & err.Description & _ ") в процедуре JoinVal модуля Module1 на строке " & Erl 120 End If 130 .ScreenUpdating = 1: .EnableEvents = 1 140 End With End Sub
Sub MergeColumnsLossless() Dim a As Range, r As Range
Application.DisplayAlerts = False For Each a In ActiveWindow.RangeSelection.Areas For Each r In a.Columns If r.Cells.Count < 2 Then Exit For r.Cells(1) = JoinRange(r, vbLf) r.Merge Next r Next a Application.DisplayAlerts = True End Sub
Private Function JoinRange(srcRng As Range, Optional delim As String = " ") As String Dim i%, k%, a% Dim txtArray() As String: ReDim txtArray(1 To srcRng.Cells.Count)
For a = 1 To srcRng.Areas.Count For i = 1 To srcRng.Areas(a).Cells.Count k = k + 1 txtArray(k) = srcRng.Areas(a).Cells(i) Next i Next a JoinRange = Join(txtArray, delim) End Function
[/vba]
Как раз на прошлой неделе наклепал себе такую.
[vba]
Код
Sub MergeColumnsLossless() Dim a As Range, r As Range
Application.DisplayAlerts = False For Each a In ActiveWindow.RangeSelection.Areas For Each r In a.Columns If r.Cells.Count < 2 Then Exit For r.Cells(1) = JoinRange(r, vbLf) r.Merge Next r Next a Application.DisplayAlerts = True End Sub
Private Function JoinRange(srcRng As Range, Optional delim As String = " ") As String Dim i%, k%, a% Dim txtArray() As String: ReDim txtArray(1 To srcRng.Cells.Count)
For a = 1 To srcRng.Areas.Count For i = 1 To srcRng.Areas(a).Cells.Count k = k + 1 txtArray(k) = srcRng.Areas(a).Cells(i) Next i Next a JoinRange = Join(txtArray, delim) End Function