Question

我已经在网上搜索了这个问题的答案，并且找到了接近但实际上根本无法让它们工作的东西，所以决定减少我的损失，并在这里问这些精彩的大师：）

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

在四个标签的每一个中，都有一个标题行，A列包含一个ID，G列包含有关所放置的实际订单的自由文本信息，例如'A＆amp; I，BHU，GUIDS，U＆amp; E' 。当我们收到这些项目时 - 我们不会立即收到这些项目 - 我们会在单元格中为相关项目添加不同的颜色。因此，对于这个订单，如果我们收到A＆amp; I和BHU，它们将是不同的颜色，但GUIDS和U＆amp; E仍然是黑色的。我知道，这是一种可怕的格式，我正在构建一个适当的应用程序来替换整个dratted的东西，但是现在我无法改变我们拥有的东西。

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

我需要的是：我需要浏览'Business 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

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

1 个答案: