copy text onto seperate lines

[redspanna]

Hi all,

I have this code..

Sub COPY_Text()
    With Sheets("sheet1")
    For MY_ROWS = 1 To 54
        If .Range("C" & MY_ROWS).Font.Underline = xlUnderlineStyleSingle Then
            MY_TEXT = MY_TEXT & .Range("C" & MY_ROWS).Value & ", "
        End If
    Next MY_ROWS
    If MY_TEXT <> "" Then
        Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(0, 6).Value = Left(MY_TEXT, Len(MY_TEXT) - 2)
      
        MY_TEXT = ""
    End If
    
    End With
    
End Sub

It will look down column C and copy any text strings that are underlined and paste them into a separate sheet..

Example: if sheet1 column c holds following..

A
Simple
Test
Hope
It
Works

the code above will give result of:

A,Test

However, I would like it to be displayed in sheet2 like below..

A
Test

so separate line and without the , to separate

any help appreciated

 

[Fluff]

Hi
How about

Sub COPY_Text()
'redspanna

    Dim MY_ROWS As Long

    With Sheets("Sheet1")
        For MY_ROWS = 1 To 54
            If .Range("C" & MY_ROWS).Font.Underline = xlUnderlineStyleSingle Then
                Sheets("Sheet2").Range("G" & Rows.Count).End(xlUp).Offset(1).Value = .Range("C" & MY_ROWS).Value
            End If
        Next MY_ROWS
    End With
    
End Sub

 

[redspanna]

Cheers Fluff

 

[Fluff]

Glad to help

 

[redspanna]

Glad to help

a follow up question if I may relating to where the copy/paste is taken / put?

I have adjusted the first part of the code to select a certain worksheet from another workbook (called Counters Report) determined from a cell ref ..
this is the actual sheet name which I want the underlined text copied from

I then want to go back to another open workbook called 'Master Report' , select the 'Report' sheet and then paste the copied text into.

How can this be achieved using the part correct code below?

Sub Copy_Text()
'redspanna

Application.ScreenUpdating = False
Dim MY_ROWS As Long
Dim REPORT_DATA As Worksheet
Dim LAST_ROW As Long
Sheets("front").Select
Range("M15").Select
Selection.Copy

For Each WB In Workbooks
If WB.Name Like "Counters Report*" Then
WB.Activate
Sheets("Front").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets(Worksheets("Front").Range("A1").Text).Activate


        For MY_ROWS = 41 To 154
           If .Range("C" & MY_ROWS).Font.Underline = xlUnderlineStyleSingle Then
              Sheets("Sheet2").Range("G" & Rows.Count).End(xlUp).Offset(1).Value = .Range("C" & MY_ROWS).Value
         End If
   Next MY_ROWS
    End With


End If
Next

appreciate any help again

 

[Fluff]

Untested but try

Sub Copy_Text()
'redspanna

    Application.ScreenUpdating = False
    Dim MY_ROWS As Long
    Dim REPORT_DATA As Worksheet
    Dim LAST_ROW As Long
    Dim wb As Workbook
    Dim DestWs As Worksheet
    
    
'    Sheets("front").Select
'    Range("M15").Select
'    Selection.Copy
    Set DestWs = Workbooks("Master Report.[COLOR=#ff0000]xlsm[/COLOR]").Worksheets("Report")
    For Each wb In Workbooks
        If wb.Name Like "Counters Report*" Then
            wb.Activate
            Sheets("Front").Select
            Range("A1").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            With Worksheets(Worksheets("Front").Range("A1").Text).Activate
                For MY_ROWS = 41 To 154
                       If .Range("C" & MY_ROWS).Font.Underline = xlUnderlineStyleSingle Then
                          DestWs.Range("G" & Rows.Count).End(xlUp).Offset(1).Value = .Range("C" & MY_ROWS).Value
                     End If
                Next MY_ROWS
            End With
        End If
    Next
    
End Sub

You may need to change the file extension in red

 

[redspanna]

Thanks again Fluff

I'm getting an Object Required error and the code is stoping on this line..

 If .Range("C" & MY_ROWS).Font.Underline = xlUnderlineStyleSingle Then

any thoughts??

There are defo lines of text that are underlined in column c so not sure why the error

 

[redspanna]

Thanks again Fluff

I'm getting an Object Required error and the code is stoping on this line..

 If .Range("C" & MY_ROWS).Font.Underline = xlUnderlineStyleSingle Then

any thoughts??

There are defo lines of text that are underlined in column c so not sure why the error

 

[Fluff]

this line

With Worksheets(Worksheets("Front").Range("A1").Text).Activate

Should be

With Worksheets(Worksheets("Front").Range("A1").Text)