OzGrid

 Category: [Excel]  Demo Available 

---

Split row into many rows using trigger in particular row cells

 

Requirement:

 

The project is to split a row into 4 rows using 4 trigger cells to define each row. The trigger cells in my samples are using columns A, P, X and AL.

I have attached a sample of data with some guiding notes that shows the source data and the required result. I have colour coded each split for better visibility.
The sheet also includes some columns (AG to AK) that are not required in one version but required in a different version as the forms meet different accounting requirements so 1 form excludes these while the other includes them.

There might be some code in there where I've found something to play with but hadn't cracked it for my purpose.

 

Solution:

 

Option Explicit

Sub Treat()
Const Col1 As String = "A"
Const Col2 As String = "P"
Const Col3 As String = "X"
Const Col4 As String = "AL"
Dim FR  As Integer, LR  As Integer, LC As Integer, I As Integer
Dim IB As Integer, IE As Integer, II As Integer
Dim DestWS  As Worksheet
Dim WkRg  As Range, Rg As Range
Dim Col1Nb As Integer, Col2Nb As Integer, Col3Nb As Integer, Col4Nb As Integer
Dim NbCoL1 As Integer, NbCoL2 As Integer, NbCoL3 As Integer, NbCoL4 As Integer

    Set DestWS = Sheets("Result")
    Set WkRg = ActiveSheet.UsedRange
    LR = WkRg.Rows.Count
    LC = WkRg.Columns.Count
    Col1Nb = Cells(1, Col1).Column: Col2Nb = Cells(1, Col2).Column: Col3Nb = Cells(1, Col3).Column: Col4Nb = Cells(1, Col4).Column
    NbCoL1 = Col2Nb - Col1Nb
    NbCoL2 = Col3Nb - Col2Nb
    NbCoL3 = Cells(1, Col4).Column - Cells(1, Col3).Column
    NbCoL4 = LC - Col3Nb
    
    For FR = 1 To LR
        If (Len(Cells(FR, 1)) <> 0) Then Exit For
    Next
    II = 1

    I = FR
    IB = FR
    Application.ScreenUpdating = False
    DestWS.Cells.ClearContents
    While (I <> LR)
        I = I + 1
        If (Len(Cells(I, 1)) <> 0) Then
            IE = I - 1
            Set WkRg = Range(Cells(IB, 1), Cells(IE, LC))
            Call CopyData(II, WkRg.Columns(Col1Nb).Cells, NbCoL1, DestWS)
            Call CopyData(II, WkRg.Columns(Col2Nb).Cells, NbCoL2, DestWS)
            Call CopyData(II, WkRg.Columns(Col3Nb).Cells, NbCoL3, DestWS)
            Call CopyData(II, WkRg.Columns(Col4Nb).Cells, NbCoL4, DestWS)
            IB = IE + 1:
        End If
    Wend
    Application.ScreenUpdating = True
    MsgBox (" job Done")
End Sub

Sub CopyData(ByRef III, WkColRg As Range, NbCol As Integer, DestWS As Worksheet)
Dim Rg  As Range
    For Each Rg In WkColRg
        If (Len(Rg) <> 0) Then
           Rg.Resize(1, NbCol).Copy
           DestWS.Cells(III, 1).PasteSpecial Paste:=xlPasteValues
           III = III + 1
        End If
    Next
End Sub

 

Obtained from the OzGrid Help Forum.

Solution provided by PCI.

 

See also: Index to Excel VBA Code and Index to Excel Freebies and Lesson 1 - Excel Fundamentals and Index to how to… providing a range of solutions and Index to new resources and reference sheets

 

See also:

How to use a macro to copy rows from multiple worksheets based on a cell value greater than zero

How to compare two columns in excel, inserting blank rows moving associated data

How to add rows and specific text after changes in data

How to use VBA to turn columns into rows

How to use a macro for grouping rows based on cells with same names

 

Click here to visit our Free 24/7 Excel/VBA Help Forum where there are thousands of posts you can get information from, or you can join the Forum and post your own questions.

Gallery

---

• 
• 
• 
• 
• 
•