Нужна помощь: копирование строки во многие строки, созданные ниже (Excel VBA) - PullRequest
Новая
       56

Нужна помощь: копирование строки во многие строки, созданные ниже (Excel VBA)

0 голосов
/ 20 февраля 2019

Новый пользователь, который также является новичком в Excel VB.

На данный момент у меня есть макрос, который делает то, что вы видите здесь.

По существу,У меня есть 2 столбца, которые иногда могут иметь ячейки, которые содержат вертикально сложенные строки данных в каждой ячейке.Каждая из этих строк разбивается и помещается во вновь вставленные ниже строки (по одной строке данных в ячейке на строку).

Проблема, с которой я столкнулся сейчас, состоит в том, что в то время как новые строки теперь содержат данные вдве колонки, которые должны были быть разделены (34 и 35), остальные ячейки пусты.У меня проблемы с переносом оставшихся 38 столбцов во вновь созданные строки.Вы можете видеть, что я имею в виду на изображении, которое я разместил.Были созданы две новые строки, и мне нужно заполнить их содержимым строки 1 (заполнить заштрихованной областью).

Вот мой код прямо сейчас.Закомментированная часть - это я пытаюсь заполнить пустое пространство.Код без комментариев делает то, что вы видите на картинке. 

Sub main()
Dim iRow As Long, nRows As Long, nData As Long
Dim IDVariables As Range
Dim arr As Variant


With Worksheets("UI").Columns("AH") 
    nRows = .Cells(.Rows.Count, 1).End(xlUp).Row 
    For iRow = nRows To 2 Step -1 
        With .Cells(iRow) 
            arr = Split(.Value, vbLf) 
            nData = UBound(arr) + 1 
            If nData > 1 Then 
                    .EntireRow.Offset(1).Resize(nData - 1).Insert 
                    .Resize(nData).Value = Application.Transpose(arr) 
                    .Offset(, 1).Resize(nData).Value = Application.Transpose(Split(.Offset(, 1).Value, vbLf)) 
                    'Set IDVariables = Range("A" & iRow & ":AG" & iRow)
                    'IDVariables.Select
                    'Selection.Copy
                    'Range("A" & (iRow + 1) & ":A" & (iRow + nData -1)).Select
                    'Selection.Paste             
            End If
        End With
    Next iRow
End With

End Sub

Любая помощь будет очень цениться.

Спасибо!

Ответы [ 2 ]

0 голосов
/ 30 апреля 2019

Я опаздываю, но разобрался.Я выложу свое решение для тех, у кого похожая проблема. 

Sub main()
Dim iRow As Long, nRows As Long, nData As Long
Dim arr As Variant
Dim IDVariables, Comments, AllocationCheck As Range

Application.ScreenUpdating = False

With Worksheets("PRM2_Computer").Columns("AH")
    nRows = .Cells(.Rows.Count, 1).End(xlUp).Row        
    For iRow = nRows To 2 Step -1
        With .Cells(iRow)
            arr = Split(.Value, vbLf)
            nData = UBound(arr) + 1
            If nData = 1 Then
                Range("AI" & iRow) = 1
                Range("AK" & iRow) = "Single Industry"
            End If
            If nData > 1 Then
                    .EntireRow.Offset(1).Resize(nData - 1).Insert
                    .Resize(nData).Value = Application.Transpose(arr)
                    .Offset(, 1).Resize(nData).Value = Application.Transpose(Split(.Offset(, 1).Value, vbLf))
                    .Offset(, 2).Resize(nData).Value = Application.Transpose(Split(.Offset(, 2).Value, vbLf))
                    Set Comments = Range("AL" & iRow & ":AM" & iRow)
                    Comments.Copy Range("AL" & (iRow + 1) & ":AL" & (iRow + nData - 1))
                    Set AllocationCheck = Range("AK" & (iRow) & ":AK" & (iRow + nData - 1))
                    AllocationCheck.Value = Application.Sum(Range("AI" & iRow & ":AI" & (iRow + nData - 1)))
                    Set IDVariables = Range("A" & iRow & ":AG" & iRow)
                    IDVariables.Copy Range("A" & (iRow + 1) & ":A" & (iRow + nData - 1))
            End If
        End With
    Next iRow
End With

End Sub

0 голосов
/ 20 февраля 2019

Проверено и работает нормально .... 

Option Explicit

Sub ReCode()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")

Dim LR As Long, i As Long, arr
LR = ws.Range("AH" & ws.Rows.Count).End(xlUp).Row

For i = LR To 2 Step -1
    If InStr(ws.Range("AH" & i), vbLf) Then
        ws.Range("A" & i + 1).EntireRow.Insert xlUp
            ws.Range("A" & i).EntireRow.Copy ws.Range("A" & i + 1)
            arr = Split(ws.Range("AH" & i), vbLf)
            ws.Range("AH" & i) = arr(0)
            ws.Range("AH" & i + 1) = arr(1)
        arr = ""
    End If
Next i

End Sub
...