Создайте новый рабочий лист на основе текста в цветных ячейках и скопируйте данные в новый рабочий лист.

У меня есть большой набор данных, которым мне нужно манипулировать и создавать отдельные рабочие листы. В столбце 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

Любая помощь в этом будет высоко оценена.


excel vba worksheet-function
person Sean Bailey    schedule 15.06.2015    source источник
comment
Вы уже пробовали делать что-то из того, что хотите, самостоятельно? Что создает вам проблемы?   -  person eirikdaude    schedule 15.06.2015
comment
Пожалуйста, смотрите обновленный вопрос. :)   -  person Sean Bailey    schedule 15.06.2015
comment
Я посмотрю на это, но это может занять некоторое время - прямо сейчас поехал домой :)   -  person eirikdaude    schedule 15.06.2015

Ответы (1)


arrow_upward
0
arrow_downward

Извините, что потребовал некоторое время, чтобы вернуться к этому, я был несколько занят последние несколько дней, поэтому у меня не было много времени, чтобы быть в 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

Вероятно, ему не хватает какой-то проверки ошибок, которая должна быть там, но я оставлю это вам в качестве упражнения, чтобы разобраться. Я считаю, что это функционально. Удачи!

person eirikdaude    schedule 19.06.2015