Получить весь черный текст из ячейки и поместить его в другой лист

Question

Я искал в Интернете ответы на эти вопросы и нашел вещи, которые подходят близко, но на самом деле не могу заставить их работать вообще, поэтому решил сократить свои потери и попросить замечательных гуру здесь:)

У меня есть рабочая тетрадь с пятью вкладками.На первых четырех вкладках записываются данные о заказах, размещенных на разных вкладках - т.е. на первой вкладке записываются заказы, размещенные с бизнесом 1, на двух вкладках - бизнес 2 и т. Д.

На каждой из четырех вкладок имеется строка заголовкаи столбец A содержит идентификатор, а столбец G содержит информацию в свободном тексте о фактических размещенных заказах, таких как «A & I, BHU, GUIDS, U & E».Когда мы получаем элементы, которые мы не получаем сразу, мы окрашиваем соответствующий элемент в ячейку другим цветом.Так что для этого заказа, если бы мы получили A & I и BHU, они были бы другого цвета, но GUIDS и U & E все еще были бы черными.Я знаю, что это ужасный формат, и я создаю правильное приложение, чтобы заменить весь набросок, но сейчас я не могу изменить то, что у нас есть.

То, что нам нужно в качестве временной меры, - это способчтобы получить невыполненные заказы.Я создал рабочий лист № 5 для этого.У него есть раздел для каждой из четырех других вкладок (я подумал, что будет проще написать более простой процесс и повторить его четыре раза, по одному разу для каждого листа).Столбцы A и B имеют заголовки «ID» и «Неоплаченные заказы» и относятся к бизнесу 1. Столбцы D и E имеют одинаковые заголовки, но относятся к бизнесу 2 и т. Д.

Что мне нужно: мне нужно пройти через столбец G на рабочем листе «Бизнес 1» и для любой ячейки, в которой есть какой-то черный текст, вернуть весь черный текст в виде строки (вырезая любой другой цвет)в одну ячейку в столбце B на рабочем листе 5 и в столбце A на рабочем листе 5 верните идентификатор (столбец A), который был в той же строке на рабочем листе 1.

Пока у меня есть что-то подобное, нона самом деле это куча мусора ... (и не компилируется)

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, и после того, как я закомментирую бит, который должен заполнитьмой идентификатор ...

Проблема в том, что он в основном проходит через КАЖДУЮ ОДНУ ЯЧКУ в диапазоне, а не только в столбце G, поэтому я получаю треугольные данные.в моих результатах я получаю в своей первой ячейке текст первой ячейки заголовка от A1 Business1.Во второй ячейке результатов я получаю объединенное значение первой ячейки заголовка + второй ячейки заголовка Business 1 (IE A1 и B1).Это происходит в формате «сквозь вниз», поэтому моя последняя строка (довольно долгое время спустя) по существу поместила весь текст из всей таблицы Business 1 в одну ячейку ... в одну строку ... хотя вЧестно говоря, это только дает мне черный текст !!!!!

Я не могу предоставить оригинальную электронную таблицу из-за проблем с обменом данными, но я, возможно, смогу сделать что-то наподобие, что даст вам идею, если этопомог бы ??

Пожалуйста, пожалуйста, пожалуйста, любая помощь будет очень очень признательна - я не программист VB и очень надеюсь, что добрый человек там пожалеет меня и покажет мне свет!!

Большое вам спасибо

edit: ссылка на мою фиктивную таблицу, где вы можете увидеть ее в действии !!(Надеюсь ...) - не мой мусорный код, а приятный материал, любезно предоставленный Тони Даллимором: 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