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

Question

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

例如，我想创建名为“Shopping”的工作表＆amp; “零售”。一旦创建了工作表，我就想复制“工作表标题”（绿色单元格）和列（“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

对此有任何帮助将非常感激。

Answer 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

它可能缺少一些错误检查应该在那里，但我会把它作为练习让你弄明白。我相信它很实用。祝你好运！