Multiple lines to multiple rows looping issue

hyungplo

New Member
Joined
Jun 25, 2021
Messages
5
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.


VBA Code:
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

1624637160284.png


Sample of output

1624637238971.png
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying

Snakehips

Well-known Member
Joined
May 17, 2009
Messages
5,384
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
@hyungplo
Does this help?

VBA Code:
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
 
Solution

hyungplo

New Member
Joined
Jun 25, 2021
Messages
5
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.

VBA Code:
Private Sub cmdSave_Click()
      
    Call Submit
    Call Reset
    Call Both
    
        
End Sub

1624684059651.png
 

Snakehips

Well-known Member
Joined
May 17, 2009
Messages
5,384
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
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

New Member
Joined
Jun 25, 2021
Messages
5

ADVERTISEMENT

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)

VBA Code:
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

Well-known Member
Joined
May 17, 2009
Messages
5,384
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
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...'

VBA Code:
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

New Member
Joined
Jun 25, 2021
Messages
5
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

New Member
Joined
Jun 25, 2021
Messages
5
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
 

Forum statistics

Threads
1,147,632
Messages
5,742,229
Members
423,714
Latest member
ftp2jz

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top