VBA define the cell

[Nani520]

Hi, appreciate if someone can assist me on the below.
I would like to create a VBA to auto copy the row which contains multiple line in Ref A or B and paste it into sheet2.
May I know how should I define the condition in VBA? (if more than 1 line in Column E or F)?

Thanks,
Lee

 

[Alex Blakenburg]

Where did the data come from (manual input, copy/paste or import) ?
If you make column E & F double or more the width so that 2 lines of data could fit on the same line do they still appear on multiple lines ?
If they still appear on separate lines they are separated by a Line Feed ASCII character 10 and that can be used to identify multiple lines.

 

[Nani520]

Where did the data come from (manual input, copy/paste or import) ?
If you make column E & F double or more the width so that 2 lines of data could fit on the same line do they still appear on multiple lines ?
If they still ap

Where did the data come from (manual input, copy/paste or import) ?
If you make column E & F double or more the width so that 2 lines of data could fit on the same line do they still appear on multiple lines ?
If they still appear on separate lines they are separated by a Line Feed ASCII character 10 and that can be used to identify multiple lines.

Is imported data. Yup, they still appear on multiple lines. Sorry not really know what is Line Feed ASCII Character 10, if this is the case, how should I define it in VBA?

 

[Alex Blakenburg]

I am sure others can give you much more compact code but see if you can follow this:
Essentially you are trying to find out if you have at least 1 Line feed character in Ref A or Ref B.
By replacing vbLF with "" and comparing the before and after length you can work out how many Line feed characters where in the text.
Line Feed - when you enter data into a cell you can add a LF by using Alt+Enter. LF is ASCII code 10.

Sub MultiLineCells()

    Dim firstRow As Long
    Dim srcSht As Worksheet
    Dim outSht As Worksheet
    Dim srcRng As Range
    Dim cRow As Range
    Dim cntLfRef_A As Long
    Dim cntLfRef_B As Long
    Dim outLastRow As Long
    
    Set srcSht = Worksheets("Sheet1")
    Set outSht = Worksheets("Sheet2")
    
    firstRow = 6
    Set srcRng = srcSht.Cells(firstRow, "A").CurrentRegion
    Set srcRng = srcRng.Offset(1, 0).Resize(srcRng.Rows.Count - 1)  ' Resize without heading row
    
    outLastRow = outSht.Cells(Rows.Count, "A").End(xlUp).Row
    
    For Each cRow In srcRng.Rows
        'do Ref_A or Ref_B have more than line feed character
        cntLfRef_A = Len(cRow.Cells(1, 5)) - Len(Replace(cRow.Cells(1, 5), vbLf, ""))
        cntLfRef_B = Len(cRow.Cells(1, 6)) - Len(Replace(cRow.Cells(1, 6), vbLf, ""))
        If cntLfRef_A <> 0 Or cntLfRef_B <> 0 Then
            ' Perform copy of row
            outLastRow = outLastRow + 1
            cRow.Copy Destination:=outSht.Cells(outLastRow, "A")
        End If

    Next cRow

End Sub

 

[Nani520]

I am sure others can give you much more compact code but see if you can follow this:
Essentially you are trying to find out if you have at least 1 Line feed character in Ref A or Ref B.
By replacing vbLF with "" and comparing the before and after length you can work out how many Line feed characters where in the text.
Line Feed - when you enter data into a cell you can add a LF by using Alt+Enter. LF is ASCII code 10.

Sub MultiLineCells()

    Dim firstRow As Long
    Dim srcSht As Worksheet
    Dim outSht As Worksheet
    Dim srcRng As Range
    Dim cRow As Range
    Dim cntLfRef_A As Long
    Dim cntLfRef_B As Long
    Dim outLastRow As Long
   
    Set srcSht = Worksheets("Sheet1")
    Set outSht = Worksheets("Sheet2")
   
    firstRow = 6
    Set srcRng = srcSht.Cells(firstRow, "A").CurrentRegion
    Set srcRng = srcRng.Offset(1, 0).Resize(srcRng.Rows.Count - 1)  ' Resize without heading row
   
    outLastRow = outSht.Cells(Rows.Count, "A").End(xlUp).Row
   
    For Each cRow In srcRng.Rows
        'do Ref_A or Ref_B have more than line feed character
        cntLfRef_A = Len(cRow.Cells(1, 5)) - Len(Replace(cRow.Cells(1, 5), vbLf, ""))
        cntLfRef_B = Len(cRow.Cells(1, 6)) - Len(Replace(cRow.Cells(1, 6), vbLf, ""))
        If cntLfRef_A <> 0 Or cntLfRef_B <> 0 Then
            ' Perform copy of row
            outLastRow = outLastRow + 1
            cRow.Copy Destination:=outSht.Cells(outLastRow, "A")
        End If

    Next cRow

End Sub
[/COD
[/QUOTE]
It's exactly what i needs. Thanks you so much.
can I ask you 1 more favour?
 If I want to paste the data in the same sheet right after the original data, is it possible?

 

[Alex Blakenburg]

Your ref: "It's exactly what i needs. Thanks you so much.
can I ask you 1 more favour?
If I want to paste the data in the same sheet right after the original data, is it possible?"

Sure but don't you want some separation to distinguish old from new ?

@Nani520
FYI when you use reply you need to type your message underneath the grey area.

 

[Nani520]

Your ref: "It's exactly what i needs. Thanks you so much.
can I ask you 1 more favour?
If I want to paste the data in the same sheet right after the original data, is it possible?"

Sure but don't you want some separation to distinguish old from new ?

@Nani520
FYI when you use reply you need to type your message underneath the grey area.

oh ya, can have1 blank row to seperate them?
would it be very complicated if I want to seperate the mulitple line into different row?
something like this

From:

To:

 

[Alex Blakenburg]

You would be better off to use Power Query to do that.

 

[Alex Blakenburg]

This code is quite clunky but should do what you want except that I am still using Sheet 2 as the output.
I probably should have rebuilt when you essentially changed the question but I used the existing code.

Sub SplitMultiLineCells()

    Dim firstRow As Long
    Dim srcSht As Worksheet
    Dim outSht As Worksheet
    Dim srcRng As Range
    Dim cRow As Range
    Dim arrRefA As Variant
    Dim arrRefB As Variant
    Dim outLastRow As Long
    Dim loopMax As Long
    Dim i As Long
    
    Set srcSht = Worksheets("Sheet1")
    Set outSht = Worksheets("Sheet2")
    
    firstRow = 6
    Set srcRng = srcSht.Cells(firstRow, "A").CurrentRegion
    Set srcRng = srcRng.Offset(1, 0).Resize(srcRng.Rows.Count - 1)  ' Resize without heading row
    
    outLastRow = outSht.Cells(Rows.Count, "A").End(xlUp).Row
    
    For Each cRow In srcRng.Rows

        arrRefA = Split(cRow.Cells(1, 5), vbLf)
        arrRefB = Split(cRow.Cells(1, 6), vbLf)

        loopMax = Application.Max(UBound(arrRefA), UBound(arrRefB))
        Debug.Assert cRow.Row <> 10
        
        If loopMax <> -1 Then             ' -1 is when both Ref cols are blank
            If UBound(arrRefA) < loopMax Then
                ReDim Preserve arrRefA(loopMax)
            Else
                ReDim Preserve arrRefB(loopMax)
            End If
                
            For i = 0 To loopMax
                outLastRow = outLastRow + 1
                cRow.Copy Destination:=outSht.Cells(outLastRow, "A")
                outSht.Cells(outLastRow, 5) = Trim(arrRefA(i))
                outSht.Cells(outLastRow, 6) = Trim(arrRefB(i))
            Next i
            
        Else
            outLastRow = outLastRow + 1
            cRow.Copy Destination:=outSht.Cells(outLastRow, "A")
        End If

    Next cRow

End Sub

 

[Nani520]

This code is quite clunky but should do what you want except that I am still using Sheet 2 as the output.
I probably should have rebuilt when you essentially changed the question but I used the existing code.

Sub SplitMultiLineCells()

    Dim firstRow As Long
    Dim srcSht As Worksheet
    Dim outSht As Worksheet
    Dim srcRng As Range
    Dim cRow As Range
    Dim arrRefA As Variant
    Dim arrRefB As Variant
    Dim outLastRow As Long
    Dim loopMax As Long
    Dim i As Long
   
    Set srcSht = Worksheets("Sheet1")
    Set outSht = Worksheets("Sheet2")
   
    firstRow = 6
    Set srcRng = srcSht.Cells(firstRow, "A").CurrentRegion
    Set srcRng = srcRng.Offset(1, 0).Resize(srcRng.Rows.Count - 1)  ' Resize without heading row
   
    outLastRow = outSht.Cells(Rows.Count, "A").End(xlUp).Row
   
    For Each cRow In srcRng.Rows

        arrRefA = Split(cRow.Cells(1, 5), vbLf)
        arrRefB = Split(cRow.Cells(1, 6), vbLf)

        loopMax = Application.Max(UBound(arrRefA), UBound(arrRefB))
        Debug.Assert cRow.Row <> 10
       
        If loopMax <> -1 Then             ' -1 is when both Ref cols are blank
            If UBound(arrRefA) < loopMax Then
                ReDim Preserve arrRefA(loopMax)
            Else
                ReDim Preserve arrRefB(loopMax)
            End If
               
            For i = 0 To loopMax
                outLastRow = outLastRow + 1
                cRow.Copy Destination:=outSht.Cells(outLastRow, "A")
                outSht.Cells(outLastRow, 5) = Trim(arrRefA(i))
                outSht.Cells(outLastRow, 6) = Trim(arrRefB(i))
            Next i
           
        Else
            outLastRow = outLastRow + 1
            cRow.Copy Destination:=outSht.Cells(outLastRow, "A")
        End If

    Next cRow

End Sub

not sure why the error message appeared when i run the macro. any idea what is this about?