从一个单元格中获取所有黑色文本，并将其放入另一个工作表中

Question

我在网上搜索了这个问题的答案，发现了一些接近的东西，但真的根本无法让它们发挥作用，所以我决定减少损失，并在这里询问优秀的大师：）

我有一本有五个选项卡的工作簿。前四个选项卡记录不同选项卡下的订单数据，即选项卡一记录与业务1下的订单，选项卡二记录业务2，依此类推

在四个选项卡中的每一个选项卡中，都有一个标题行，a列包含一个ID，G列包含关于实际下订单的自由文本信息，例如"a&I、 BHU，GUIDS，U&E’。当我们收到这些物品时——我们不会一次收到所有物品——我们会在单元格中为相关物品涂上不同的颜色。所以对于这个订单，如果我们收到A&我和BHU，它们将是不同的颜色，但GUIDS和U&E仍然是黑色的。我知道，这是一种糟糕的格式，我正在构建一个合适的应用程序来替换整个dratted的东西，但目前我无法更改我们所拥有的。

作为一项临时措施，我们需要的是获得未完成订单的方法。我已经为此设置了5号工作表。它为其他四个选项卡中的每一个都有一个部分（我认为写一个更简单的过程并重做四次会更容易，每张表一次）。列A和B具有标题"ID"one_answers"未完成订单"，并且与业务1相关。列D和E具有相同的标题，但与业务2有关，依此类推

我需要的是：我需要遍历"业务1"工作表中的G列，对于任何有黑色文本的单元格，将所有黑色文本作为字符串（去掉任何其他颜色）返回到工作表5的B列中的一个单元格中，并在工作表5中的a列中返回业务1工作表上同一行的ID（a列）。

到目前为止，我有这样的东西，但这真的是一堆垃圾。。。（并且不编译）

Sub ProduceLateList()
    Dim r As Range
    Dim cell As Range
    Dim i1 As Integer
    Dim EmptyRow As Long
    EmptyRow = 0
    For Each r In Worksheets("Business 1").Range("G2").CurrentRegion
      For Each cell In r.Cells
        Dim sColoredText
        For i1 = 1 To Len(cell.Value)
            If (cell.Characters(i1, 1).Font.Color = RGB(0, 0, 0)) Then
                sColoredText = sColoredText & Mid(cell, i1, 1)
            End If
        Next i1
        With Worksheets("Worksheet 5").Range("A2")
            If sColoredText <> "" Then
                .Offset(EmptyRow, 1).Value = sColoredText
                .Offset(EmptyRow, 0).Value = Worksheets("Business 1").Cells(cell.r, 0).Value
            End If
        End With
        EmptyRow = EmptyRow + 1
      Next cell
    Next r
End Sub

在JMax提供的帮助之后，在我注释掉应该填写我的ID的位之后，现在确实进行了编译。…

问题是，它基本上会遍历范围内的每个单元格，而不仅仅是G列的范围，所以我得到了三角形数据。在我的结果中，我在第一个单元格中获得了Business1的A1中的第一个标题单元格文本。在结果的第二个单元格中，我得到业务1的第一个标题单元格+第二个标题单元格的级联值（IE A1和B1）。它以一种先跨后下的格式进行，所以我的最后一行（相当长一段时间后）基本上将整个Business 1工作表中的所有文本都放在了一个单元格中。。。在一行。。。尽管公平地说，它只是给了我黑色的文本！！！！！

由于数据共享问题，我无法提供原始的电子表格，但我可能会模拟一些东西，如果它有帮助的话，会给你一个想法？？

请原谅，任何帮助都将不胜感激——我不是VB程序员，我真的希望有一个善良的人会怜悯我，给我光明！！

非常感谢

编辑：我的虚拟电子表格的链接，你可以在那里看到它的实际操作！！（希望…）-不是我的垃圾代码，而是Tony Dallimore好心提供的好东西：http://www.mediafire.com/?ndqu98giu4jjmlp

Answer 1

我已经更仔细地阅读了你的问题。第一次阅读时，我没有注意到你只想分析G列中的数据，也没有注意到需要复制A列中的值。

我不能通过修改你的守则来实现这一点。我已经把它评论掉了，以防你想看它，并添加了一个新的循环。我希望这更接近你所寻求的

Sub ProduceLateList()
  Dim r As Range
  Dim i1 As Integer
  Dim EmptyRow As Long
  ' It is always best to type variables.
  ' You cannot declare variables inside a loop with VBA.
  ' Why the name sColored text when it is to contain
  ' non-coloured text?
  Dim sColoredText As String
  Dim RowSrcCrnt As Long
  Dim RowSrcLast As Long
  Dim Id As String
  ' Set is only for Objects
  EmptyRow = 2
  ' This will delete any existing values in Worksheet 5
  ' except the header row
  With Worksheets("Worksheet 5")
    .Range(.Rows(2), .Rows(Rows.Count)).EntireRow.Delete
  End With
  With Worksheets("Sheet2")
    ' Find last used row in column G
    RowSrcLast = .Cells(Rows.Count, "G").End(xlUp).Row
  End With
  For RowSrcCrnt = 2 To RowSrcLast
    With Worksheets("Business 1")
      With .Cells(RowSrcCrnt, "G")
        sColoredText = ""
        If IsNull(.Font.Color) Then
          ' Cell is a mixture of colours
          If IsNumeric(.Value) Or IsDate(.Value) Then
            ' Cannot colour parts of a number or date
          Else
            ' Analyse this multi-coloured text
            For i1 = 1 To Len(.Value)
              If (.Characters(i1, 1).Font.Color = RGB(0, 0, 0)) Then
                sColoredText = sColoredText & .Characters(i1, 1).Text
              End If
            Next i1
          End If
        Else
          ' Cell is a single colour
          If .Font.Color = RGB(0, 0, 0) Then
            ' Entire cell is black
            sColoredText = .Value
          End If
        End If
      End With
      If sColoredText <> "" Then
        Id = .Cells(RowSrcCrnt, "A").Value
      End If
    End With
    If sColoredText <> "" Then
      With Worksheets("Worksheet 5")
        .Cells(EmptyRow, "B").Value = sColoredText
        .Cells(EmptyRow, "A").Value = Id
        EmptyRow = EmptyRow + 1
      End With
    End If
  Next
  'For Each r In Worksheets("Business 1").Range("B2").CurrentRegion
  '  ' Without this, sColoredText just gets bigger and bigger
  '  sColoredText = ""
  '  ' r.font.color will return Null if the cell have a mixture
  '  ' of colours.  No point examining single characters if the
  '  ' whole cell is one colour.
  '  If IsNull(r.Font.Color) Then
  '    ' Cell is a misture of colours
  '    ' It is not possible to colour bits of a number or a date
  '    ' nor is it possible to access individual characters
  '    If IsNumeric(r) Or IsDate(r) Then
  '      ' Cannot colour parts of a number or date
  '    Else
  '      ' Analyse this multi-coloured text
  '      For i1 = 1 To Len(r.Value)
  '        If (r.Characters(i1, 1).Font.Color = RGB(0, 0, 0)) Then
  '          ' You can only use Mid to access sub-strings within a
  '          ' string or variant variable.
  '          sColoredText = sColoredText & r.Characters(i1, 1).Text
  '        End If
  '      Next i1
  '    End If
  '  Else
  '    ' Cell is a single colour
  '    If r.Font.Color = RGB(0, 0, 0) Then
  '      ' Entire cell is black
  '      sColoredText = r.Value
  '    End If
  '  End If
  '  ' I have moved the If sColoredText <> "" Then because
  '  ' you do not need to look at the destination sheet
  '  ' unless it contains something.
  '  If sColoredText <> "" Then
  '    ' I find your use of offset confusing.  I have replaced it
  '    ' with Cells(row,column)
  '    With Worksheets("Sheet5")
  '      .Cells(EmptyRow, "B").Value = sColoredText
  '      ' r is a single cell range.  You do not need to do
  '      ' qualify it to get its value.
  '      .Cells(EmptyRow, "A").Value = r.Value
  '      EmptyRow = EmptyRow + 1
  '    End With
  '  End If
  'Next r
End Sub