根據彩色單元格中的文本創建新的工作表，並將數據復制到新的工作表中

Question

我有一個很大的數據集，需要處理和創建單個工作表。 在B列中，我要為其新建一個新的工作表，所有顯示為綠色的單元格。 請查看屏幕截圖。

例如，我想創建名為“購物”和“零售”的工作表。 創建工作表后，我想在列（“ 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

它可能缺少應該在其中的一些錯誤檢查，但是我將其留給您作為練習來找出。 我相信它是功能性的。 祝好運！