Multiple lines to multiple rows looping issue

[hyungplo]

Hi there,

I have set up an userform to input checklist question and requirement. I'm using the code below to split multiple lines to multiple rows. It works, but for only one cell. I would really appreciate your help on this matter, how to make this apply to the whole column A and B instead of just one cell.

Sub Question()

Dim cel As Range
Dim SplitText

    For Each cel In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
        
        SplitText = Split(cel, vbLf)
        
        If UBound(SplitText) > 0 Then 'If successful it will be > 0
            '
            Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Resize(UBound(SplitText) + 1).Value = Application.Transpose(SplitText)
        End If
    Next cel
    

End Sub

Sub Requirement()

Dim cel1 As Range
Dim SplitText1

    
    For Each cel1 In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
        
        SplitText1 = Split(cel1, vbLf)
        
        If UBound(SplitText1) > 0 Then 'If successful it will be > 0
           
            Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row).Resize(UBound(SplitText1) + 1).Value = Application.Transpose(SplitText1)
        End If
    Next cel1

End Sub

Sample of Input

Sample of output

 

[Snakehips]

@hyungplo
Does this help?

Sub Both()
Dim r As Long
Dim cel As Range
Dim Requ() As String
Dim Quest() As String
Dim SplitQuest() As String
Dim SplitRequ() As String
Dim LastRow As Long
Dim ubq As Integer
Dim ubr As Integer

ubq = 0
ubr = 0
LastRow = Range("A" & Rows.Count).End(xlUp).Row

    For r = 2 To LastRow
        
        SplitQuest = Split(Cells(r, 1), vbLf)
        SplitRequ = Split(Cells(r, 2), vbLf)
        
        ReDim Preserve Quest(ubq + UBound(SplitQuest) + 1)
        ReDim Preserve Requ(ubr + UBound(SplitRequ) + 1)
        For e = 0 To UBound(SplitQuest)
            Quest(ubq + e) = SplitQuest(e)
        Next e
        For e = 0 To UBound(SplitRequ)
            Requ(ubr + e) = SplitRequ(e)
        Next e
        
        ubq = UBound(Quest)
        ubr = UBound(Requ)
    
    Next r
    Range("A2:A" & LastRow).Resize(UBound(Quest) + 1).Value = Application.Transpose(Quest)
    Range("B2:B" & LastRow).Resize(UBound(Requ) + 1).Value = Application.Transpose(Requ)
    Beep
End Sub

 

[hyungplo]

Thanks Snakehips,

It totally worked! Can I ask one more question? How to make it run after the submit call? I tried to put it in the Save click and the Submit sub but there is this error. I'm fairly new to VBA so I'd really appreciate your help.

Private Sub cmdSave_Click()
      
    Call Submit
    Call Reset
    Call Both
    
        
End Sub

 

[Snakehips]

I'm pleased that it worked.
For the code to be called on a form's button click, the code should be within the Form's Code Module.
I would suspect that you have the code within a Worksheet module?

In the vba editor, right click your form > View Code >and paste the code within that pane.
Or, it should work if the code is in a Code Module.

 

[hyungplo]

Hi Snakehips,

If it would not be too much of a trouble, can you please take a look at my code for Submit call? Thank you very much. The error happens at the line Range("A2:A" & LastRow).Resize(UBound(Quest) + 1).Value = Application.Transpose(Quest)

Private Sub cmdSave_Click()
      
    Dim ws As Worksheet
    Dim iRow As Long
    Set ws = Worksheets("Database")
    
    iRow = [Counta(Database!A:A)] + 1
    With ws
        .Cells(iRow, 1) = frmform.txtRequirement.Value
        .Cells(iRow, 2) = frmform.txtSofRequirement.Value
        .Cells(iRow, 3) = frmform.txtSectionName.Value
    End With
    
    iRow = [Counta(Database!A:A)] 
    With frmform
        .txtRequirement.Value = ""
        .txtSectionName.Value = ""
        .txtSofRequirement.Value = ""
        .lstDatabase.ColumnHeads = True
        .lstDatabase.ColumnWidths = "75,30,75"
        
        If iRow > 1 Then
            .lstDatabase.RowSource = "Database!A2:C" & iRow
        Else
            .lstDatabase.RowSource = "Database!A2:C2"
            
        End If
           
    End With
    
    Dim r As Long
    Dim cel As Range
    Dim Requ() As String
    Dim Quest() As String
    Dim SplitQuest() As String
    Dim SplitRequ() As String
    Dim LastRow As Long
    Dim ubq As Integer
    Dim ubr As Integer
    
    ubq = 0
    ubr = 0
    LastRow = Range("A" & Rows.Count).End(xlUp).Row

    For r = 2 To LastRow
        
        SplitQuest = Split(Cells(r, 1), vbLf)
        SplitRequ = Split(Cells(r, 2), vbLf)
        
        ReDim Preserve Quest(ubq + UBound(SplitQuest) + 1)
        ReDim Preserve Requ(ubr + UBound(SplitRequ) + 1)
        For e = 0 To UBound(SplitQuest)
            Quest(ubq + e) = SplitQuest(e)
        Next e
        For e = 0 To UBound(SplitRequ)
            Requ(ubr + e) = SplitRequ(e)
        Next e
        
        ubq = UBound(Quest)
        ubr = UBound(Requ)
    
    Next r
    Range("A2:A" & LastRow).Resize(UBound(Quest) + 1).Value = Application.Transpose(Quest)
    Range("B2:B" & LastRow).Resize(UBound(Requ) + 1).Value = Application.Transpose(Requ)
    Beep
    
End Sub

 

[Snakehips]

I'm suspecting that it is the lack of definition of the applicable sheet?
'Assuming that the code may not all apply to 'Datatbase', I have added a second 'Set ws' where you will need to edit the name accordingly.
Then the lines with '**** create a second 'With ws...'

Private Sub cmdSave_Click()
      
    Dim ws As Worksheet
    Dim iRow As Long
    Set ws = Worksheets("Database")
    
    iRow = [Counta(Database!A:A)] + 1
    With ws
        .Cells(iRow, 1) = FrmForm.txtRequirement.Value
        .Cells(iRow, 2) = FrmForm.txtSofRequirement.Value
        .Cells(iRow, 3) = FrmForm.txtSectionName.Value
    End With
    
    iRow = [Counta(Database!A:A)]
    With FrmForm
        .txtRequirement.Value = ""
        .txtSectionName.Value = ""
        .txtSofRequirement.Value = ""
        .lstDatabase.ColumnHeads = True
        .lstDatabase.ColumnWidths = "75,30,75"
        
        If iRow > 1 Then
            .lstDatabase.RowSource = "Database!A2:C" & iRow
        Else
            .lstDatabase.RowSource = "Database!A2:C2"
            
        End If
           
    End With
    
    Dim r As Long
    Dim cel As Range
    Dim Requ() As String
    Dim Quest() As String
    Dim SplitQuest() As String
    Dim SplitRequ() As String
    Dim LastRow As Long
    Dim ubq As Integer
    Dim ubr As Integer
    
    ubq = 0
    ubr = 0
    
    '******************
    Set ws = Worksheets("??????")   '<<< Edit to suit applicable sheet
    '******************
    With ws  '*****
    LastRow = .Range("A" & Rows.Count).End(xlUp).row  '******

    For r = 2 To LastRow
        
        SplitQuest = Split(Cells(r, 1), vbLf)
        SplitRequ = Split(Cells(r, 2), vbLf)
        
        ReDim Preserve Quest(ubq + UBound(SplitQuest) + 1)
        ReDim Preserve Requ(ubr + UBound(SplitRequ) + 1)
        For e = 0 To UBound(SplitQuest)
            Quest(ubq + e) = SplitQuest(e)
        Next e
        For e = 0 To UBound(SplitRequ)
            Requ(ubr + e) = SplitRequ(e)
        Next e
        
        ubq = UBound(Quest)
        ubr = UBound(Requ)
    
    Next r
    
    .Range("A2:A" & LastRow).Resize(UBound(Quest) + 1).Value = Application.Transpose(Quest)  '*****
    .Range("B2:B" & LastRow).Resize(UBound(Requ) + 1).Value = Application.Transpose(Requ)    '*****
    
  End With   '********
    
End Sub

Hope that helps.

 

[hyungplo]

I tried but it only worked when I press F5 in the VBA code. If I filled out the form, it did not run the split sub. I'm sorry for the inconvenience.

 

[hyungplo]

Dear Snakehips,

Thank you so much for helping me. The code now works perfectly for my sheet. I really appreciate your time and effort in solving this with me.

Have a good day ahead, sir