根据彩色单元格中的文本创建新工作表，并将数据复制到新工作表中答案

【问题标题】：Create new worksheet based on text in coloured cells, and copy data into new worksheet根据彩色单元格中的文本创建新工作表，并将数据复制到新工作表中
【发布时间】：2015-06-19 14:47:01
【问题描述】：

我有一个大型数据集，我需要操作和创建单独的工作表。在 B 列中，所有颜色为 Green 的单元格我想为其制作一个新工作表。请看屏幕截图。

例如，我想创建标题为“购物”和“零售”的工作表。创建工作表后，我想从列（“B：C”）和（“AI：BH”）中复制“工作表标题”（绿色单元格）之间的所有数据，请参阅下面的屏幕截图以获取预期输出;

到目前为止，我的代码如下所示，它并不完整，因为我不知道如何在“绿色单元格”之间提取数据。

Sub wrksheetadd()

Dim r As Range
Dim i As Long
Dim LR As Long
Worksheets("RING Phased").Select

LR = Range("B65536").End(xlUp).Row
Set r = Range("B12:B" & (LR))

For i = r.Rows.Count To 1 Step -1
    With r.Cells(i, 1)
        If .DisplayFormat.Interior.ColorIndex = 35 Then
        MsgBox i
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Cells (i,1).Value
        Worksheets("RING Phased").Select
        End If
    End With
Next i

End Sub

我们将不胜感激。

【问题讨论】：

您是否尝试过自己做任何您想做的事情？是什么给你带来了问题？
请查看更新后的问题。 :)
我会看看，但可能需要一点时间 - 现在回家了 :)

标签： vba excel worksheet-function

【解决方案1】：

很抱歉，我花了一些时间回到这个问题上，这几天我有点忙，所以我没有太多时间在 StackOverflow 上。

无论如何，我的做法是将所有找到的值存储在一个数组中，然后遍历该数组以找到它们之间的距离。

以下代码对我有用，使用了一些非常简化的数据，但我认为原理是合理的：

Option Explicit
Option Base 0

Sub wrksheetadd()

  Dim r As Range, c As Range
  Dim i As Long: i = 0
  Dim cells_with_color() As Range: ReDim cells_with_color(1)

  With Worksheets("RING Phased")
    ' Since it doesn't seem like the first cell you want to copy from is colored, hardcode that location here.
    ' This also saves us from having to test if the array is empty later.
    Set cells_with_color(i) = .Range("B12")
    i = i + 1
    Set r = Range(.Range("B13"), .Range("B" & .Cells.Rows.Count).End(xlUp))

    ' Put all the cells with color in the defined range into the array
    For Each c In r
      If c.DisplayFormat.Interior.ColorIndex = 35 Then
        If i > UBound(cells_with_color) Then
          ReDim Preserve cells_with_color(UBound(cells_with_color) + 1)
        End If
        Set cells_with_color(i) = c
        i = i + 1
      End If
    Next

    ' Loop through the array, and copy from the previous range value to the current one into a new worksheet
    ' Reset counter first, we start at 1, since the first range-value (0 in the array) is just the start of where we started checking from
    ' (Hmm, reusing variables may be bad practice >_>)
    i = 1
    While i <= UBound(cells_with_color)
      Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = cells_with_color(i).Value
      ' Set the range to copy - we could just do this in the copy-statement, but hopefully this makes it slightly easier to read
      Set r = .Rows(CStr(cells_with_color(i - 1).Row) + 1 & ":" & CStr(cells_with_color(i).Row))
      ' Change the destination to whereever you want it on the new sheet. I think it has to be in column one, though, since we copy entire rows.
      ' If you want to refine it a bit, just change whatever you set r to in the previous statement.
      r.Copy Destination:=Worksheets(CStr(cells_with_color(i).Value)).Range("A1")
      i = i + 1
    Wend
  End With
End Sub

它可能缺少一些应该存在的错误检查，但我将把它作为练习留给你去弄清楚。我相信它是功能性的。祝你好运！

【讨论】：