Question

打开图片并查看每行的评论

Source_Sheet

我需要从每一行复制评论，然后将它们粘贴在图片中，作为第一个CELL的每一行的新表格，然后将头部单元格重命名为“No。” - 姓名 - 手机“。

NEW_Created_Sheet

首先，我需要创建一个新的工作表，其名称与首选的Cell1 IN相同 ROW

Answer 1

我之前没有尝试过处理评论，所以我认为我已经去了。

假设您显示的确切格式：

<强>代码：

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

注意：

借用了一个函数来检查来自@Rory
我循环所有注释，使用函数WorksheetExists检查工作表名称是否已存在，其中A列的值与注释位于同一行;如果没有，我添加工作表并命名，并使用headers变量添加标题行。否则，我将ws工作表变量设置为具有匹配名称的工作表。
我在评论文本上调用ReplacedString函数来查找模式"^\S*"的所有匹配项，即空格之前的字符串，例如No:; NAME: ....我将这些字符串替换为vbNullString，基本上是""。
我在此调用Split函数，通过在换行符Chr$(10)上拆分现已处理的注释文本来创建数组。 Chr$是一种类型化的函数，在这种情况下效率更高。
我做了一个快速测试，标题确实存在于要用IIf(GetLastRow(ws, 1) = 1, 2, GetLastRow(ws, 1) + 1)写入的工作表中。这可以确保我写出忽略标题行的下一个可用行。
我将数组中的拆分注释文本arr写到适当工作表中的一行。当我在新行上拆分时，数组项应该有arr(0) = "No"，arr(1) = "Name"）等。

示例运行：

正则表达式匹配及解释：

将单元格注释复制为过去作为每行的隔离单元格

1 个答案: