Разделить ячейки по разрыву строки VBA

Victoria G спросил: 10 мая 2018 в 04:37 в: vba

У меня есть набор данных с 40 столбцами и ~ 5000 строк. В столбцах L и M есть многострочные ячейки с разрывами строк, и мне нужно разбить эти строки на отдельные строки, но сохраните информацию в других столбцах одинаково для этих новых строк. Я пробовал несколько кодов VBA, но ни один из них не выполняет трюк для двух столбцов.


2 ответа

Есть решение
Miqi180 ответил: 12 мая 2018 в 10:21

Это будет работать для чисел и строк, но не для формул. Это также не подходит для отформатированных ячеек:

Sub multilineCellsToSeparateCells(rng As Range)        Dim i As Long, j As Long, ubnd As Long
        Dim cll As Range
        Dim arrVals As Variant, tempVal As Variant, vItem As Variant        With rng            ReDim arrVals(.Rows(1).Row To rng.Rows.Count, 1 To 1) As Variant
            For Each cll In rng.Cells
                tempVal = cll.Value2
                If InStr(1, tempVal, Chr(10)) > 0 Then
                    vItem = Split(tempVal, Chr(10))
                    i = i + 1
                    ubnd = UBound(vItem)
                    For j = 0 To ubnd
                        arrVals(i + j, 1) = vItem(j)
                    Next j
                    i = i + ubnd                ElseIf tempVal <> vbNullString Then
                    i = i + 1
                    arrVals(i, 1) = tempVal
                End If            Next cll            .Value2 = arrVals
            .AutoFit ' optional        End WithEnd Sub

Пример

Запишите это в столбце A:

A1: 1
A2: 2
A3: 3
A4: This
    is
    a 
    test
A5: 5

Вызвать Sub, а вывод будет:

A1: 1
A2: 2
A3: 3
A4: This
A5: is
A6: a 
A7: test
A8: 5

Суб фиксирует по одному столбцу за раз. Вызвать это следующим образом:

Call multilineCellsToSeparateCells(Activesheet.Columns("A"))
Victoria G ответил: 04 июня 2018 в 02:18

Код ниже работал для меня (вытащил из разных кодов, размещенных на этом сайте и моих собственных). Проблема заключалась в том, что он не будет работать должным образом, если бы были какие-то значения с # N / A, поэтому он включал удаление этих файлов перед запуском кода. Этот код включает в себя создание нового листа, разделение его на разрыв строки и последующее объединение его в один лист.

Sub CreateMasterDataPull()Sheets("DataPull").Unprotect
Sheets("DataPull").Columns("A:A").Insert Shift:=xlToRight,         
CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Value = "MasterID"
Sheets("DataPull").Select
ActiveSheet.Copy after:=Sheets(Sheets.Count)
Dim tmpArr As Variant
Dim Cell As Range
For Each Cell In Range("U2", Range("V2").End(xlDown))
If InStr(1, Cell, Chr(10)) <> 0 Then
tmpArr = Split(Cell, Chr(10))
If Cell.Offset(1) <> Cell Then
Cell.EntireRow.Copy
Cell.Offset(1, 0).Resize(UBound(tmpArr), 1). _
EntireRow.Insert xlShiftDown
End If
Cell.Resize(UBound(tmpArr) + 1, 1) = Application.Transpose(tmpArr)
End If
Next
Application.CutCopyMode = FalseSheets("DataPull").Select
Range("A2:A" & Cells(Rows.Count, "B").End(xlUp).Row).Formula = "=""Master""&RC[1]"Sheets("DataPull (2)").Select
Range("A2:A" & Cells(Rows.Count, "B").End(xlUp).Row).Formula = "=RC[1]&RC[20]&RC[30]"Sheets("DataPull (2)").Select
Rows("2:2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.CopySheets("DataPull").Select
Range("A2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets("DataPull (2)").Select
Application.CutCopyMode = False
ActiveWindow.SelectedSheets.DeleteSelection.RowHeight = 14.5Columns("A:A").ColumnWidth = 10.64Rows("1:1").Select
Selection.Font.Bold = True
Cells.Select
With Selection.Font
.Name = "Calibri"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
With Selection.Font
.Name = "Calibri"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End WithSheets("DataPull").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
    , AllowFormattingCells:=True, AllowSorting:=True, AllowFiltering:=TrueSheets("Dashboard").ActivateMsgBox "Your data pull has finished running."End Sub

Дополнительное видео по вопросу: Разделить ячейки по разрыву строки VBA

Разбивка строки текста на символы в Excel: программирование на VBA

-30- VBA Excel. Как определить номер последней заполненной строки

-53- VBA Excel. Функции Len Mid Right. Как определить корневой каталог