從單元格中獲取所有黑色文本並將其放入另一個工作表中

Question

我已經在網上搜索這個答案，並且發現了一些接近的東西但實際上無法讓它們工作，所以決定減少我的損失並在這裏問精彩的大師:)

我有一個工作簿有五個選項卡。前四個選項卡記錄關於不同選項卡下的訂單的數據 - 即選項卡1記錄與業務1放置的訂單，選項卡2記錄業務2等等。

在各四個選項卡的，有一個標題行和列A包含的ID，和G列包含有關配置在實際訂單FREETEXT信息，如「A & I，BHU，GUIDS，U &È 」。當我們收到物品 - 我們沒有一次收到 - 我們在單元格中爲相關物品塗上不同的顏色。所以對於這個訂單，如果我們收到了A和012，我們將會看到不同的顏色，但是GUIDS和UE仍然是黑色的。我知道，這是一種可怕的格式，我正在建立一個適當的應用程序來取代整個有爭議的事情，但現在我無法改變我們擁有的東西。

我們作爲臨時措施需要的是獲得未完成訂單的方式。我爲此設置了5號工作表。它爲其他四個選項卡中的每一個選項卡都有一個部分（我認爲編寫一個更簡單的過程會更容易，並重復執行四次，每次更新一次）。 A欄和B欄的標題爲'ID'和'Orders Outstanding'，並與商業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中的第一個標題單元格文本。在結果的第二個單元格中，我得到第一個標題單元格+ Business 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