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

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

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

在四个选项卡中，每个选项卡都有一个标题行，a列包含一个ID，G列包含有关实际下订单的自由文本信息，例如“a&I、BHU、GUID、U&E”。当我们收到项目时（我们不是一次收到所有项目），我们会在单元格中为相关项目涂上不同的颜色。因此，对于这个订单，如果我们收到A&I和BHU，它们将是不同的颜色，但GUIDS和U&E仍然是黑色的。我知道，这是一种可怕的格式，我正在构建一个合适的应用程序来替换整个dratted的东西，但是现在我不能改变我们现有的

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

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

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

子产品列表（）
调光范围
暗淡单元格作为范围
作为整数的Dim i1
暗空如长
EmptyRow=0
对于工作表中的每个r（“业务1”）。范围（“G2”）。当前区域
对于r.单元格中的每个单元格
暗色文字
对于i1=1到Len（单元格值）
如果（cell.Characters（i1,1）.Font.Color=RGB（0,0,0）），那么
sColoredText=sColoredText&Mid（单元格，i1，1）
如果结束
下一个i1
带工作表（“工作表5”）。范围（“A2”）
如果是sColoredText“”，则
.Offset（EmptyRow，1）.Value=sColoredText
.Offset（EmptyRow，0）.Value=工作表（“业务1”）.Cells（cell.r，0）.Value
如果结束
以
EmptyRow=EmptyRow+1
下一个细胞
下一个r
端接头

在JMax提供的帮助之后，在我注释掉应该填充我的ID的位之后，它现在可以编译了

问题是，它基本上通过了范围内的每个单元格，而不仅仅是G列范围，所以我得到了三角形数据。在我的结果中，我在我的第一个单元格中得到Business1的A1中的第一个标题单元格文本。在结果的第二个单元格中，我得到了业务1（即A1和B1）的第一个标题单元格+第二个标题单元格的连接值。它以一种前后交叉的格式进行，所以我的最后一行（相当长一段时间后）基本上将整个Business 1工作表中的所有文本都放在一个单元格中…在一行上…虽然公平地说，它只给了我黑色文本

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

请，任何帮助都将非常感谢-我不是一个VB程序员，我真的希望一个善良的人会同情我，给我光明

多谢各位

编辑：一个链接到我的虚拟电子表格，你可以看到它的行动！！（希望…）-不是我的垃圾代码，而是Tony Dallimore提供的好东西：

---

我已经更仔细地阅读了你的问题。第一次阅读时，我没有注意到您只想分析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

子产品列表（）
调光范围
作为整数的Dim i1
暗空如长
'最好总是键入变量。
'不能在使用VBA的循环中声明变量。
'为什么名称在要包含的文本上涂上颜色
'非彩色文本？
Dim sColoredText作为字符串
暗淡的行与长的行相同
它能持续多久
作为字符串的Dim Id
'设置仅适用于对象
EmptyRow=2
'这将删除工作表5中的任何现有值
'标题行除外
带工作表（“工作表5”）
.Range（.Rows（2），.Rows（Rows.Count））.EntireRow.Delete
以
带工作表（“表2”）
'查找G列中最后使用的行
rowsclast=.Cells（Rows.Count，“G”）.End（xlUp）.Row
以
对于RowSrcRnt=2到RowSrcLast
带工作表（“业务1”）
带.Cells（RowSrcCrnt，“G”）
sColoredText=“”
如果为空（.Font.Color），则
“细胞是多种颜色的混合物
如果是数字（.Value）或IsDate（.Value），则
'不能为数字或日期的部分着色
其他的
“分析这个多色文本
对于i1=1到Len（.Value）
如果（.Characters（i1,1）.Font.Color=RGB（0,0,0）），则
sColoredText=sColoredText和.Characters（i1，1）.Text
如果结束
下一个i1
如果结束
其他的
“细胞是单色的
如果.Font.Color=RGB（0,0,0），则
“整个细胞是黑色的
sColoredText=.Value
如果结束
如果结束
以
如果斯科洛
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