Copy Cell Comments to past as isolated Cells for Each line

Question

Open Down Picture and look at Comment for each rows

I need to to Copy comments from each rows, then paste them like in the picture as a new sheet for each row by name the first CELL, then rename the head cells as "No. - Name - Mobile".

First I need to create a new worksheet, named the same as first Cell1 IN selected ROW

Answer 1

I haven't tried working with comments before so thought i'd have a go.

Assuming in the exact format you have shown:

Code:

Option Explicit

Public Sub LoopComments()
    Dim c As Comment, ws As Worksheet, headers As Variant
    headers = Array("No", "Name", "Mobile", "Location")

    Application.ScreenUpdating = False

    With ThisWorkbook.Worksheets("Sheet1")
        For Each c In .Comments
            Dim sheetName As String
            sheetName = .Cells(c.Parent.Row, 1)

            If Not WorksheetExists(sheetName) And sheetName <> vbNullString Then
                Set ws = ThisWorkbook.Worksheets.Add
                ws.Name = sheetName
                ws.Cells(1, 1).Resize(1, UBound(headers) + 1).Value = headers
            ElseIf WorksheetExists(sheetName) And sheetName <> vbNullString Then
                Set ws = ThisWorkbook.Worksheets(sheetName)
            End If

            Dim arr() As String
            arr = Split(ReplacedString(c.Text), Chr$(10))

            Dim nextRow As Long
            nextRow = IIf(GetLastRow(ws, 1) = 1, 2, GetLastRow(ws, 1) + 1) '<= should be headers
            ws.Cells(nextRow, 1).Resize(1, UBound(arr) + 1).Value = arr
        Next c
    End With
    Application.ScreenUpdating = True
End Sub

'https://stackoverflow.com/questions/6688131/test-or-check-if-sheet-exists?utm_medium=organic&utm_source=google_rich_qa&utm_campaign=google_rich_qa
Public Function WorksheetExists(ByVal sName As String) As Boolean
    WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function

Public Function ReplacedString(ByVal t As String) As String

    With CreateObject("VBScript.RegExp")         ''Late binding if not add Microsoft vbscript regular expressions reference for early binding
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .pattern = "^\S*"
        Dim outputString As String, currMatch As Object
        outputString = t

        If .test(outputString) Then
            For Each currMatch In .Execute(t)
                outputString = Replace(outputString, currMatch.Value, vbNullString)
            Next currMatch
        Else
            ReplacedString = t
            Exit Function
        End If
    End With

    ReplacedString = outputString
End Function

Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
    With ws
        GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
    End With
End Function

Notes:

1. Have borrowed a function to check if sheet exists from @Rory
2. I loop all the comments, check whether a sheet name already exists, using the function WorksheetExists, with the value of column A in the same row as the comment; if it doesn't, I add the sheet and name it, aswell as add the headers row using headers variable. Otherwise, I set the ws worksheet variable to the sheet with the matching name.
3. I call the ReplacedString function on the comment text to find all matches to pattern "^\S*" i.e. the string before a space e.g. No: ; NAME: .... I replace these strings with vbNullString, essentially "".
4. I call the Split function on this to create an array by splitting, the now processed comment text, on the newline character Chr$(10). Chr$ is a typed function and more efficient in this case.
5. I do a quick test that headers are indeed in place in the sheet to write to with IIf(GetLastRow(ws, 1) = 1, 2, GetLastRow(ws, 1) + 1). This ensures I write out to the next available row ignoring the header row.
6. I write the split comment text in the array, arr, out to a row in the appropriate sheet. As I split on the new line, the array items should have arr(0) = "No", arr(1) = "Name") etc.

Example run:

Regex matches and explanation: