Контрольная проверка невыясненных вопросов...

[sonata]

Есть общий файл, в котором ведутся различные темы,
каждый лист определяет свою тему.
По теме могут возникать вопросы...
Ответы на которые, со временем хотелось бы выяснить...
Время проходит-вопросы забываются...И остаются невыясненными...
Что я хочу:
Делать проверку:по всем листам на наличие знака "?" или,
например, вопросительное предложение выделять особенным цветом,
наверное, это было бы быстрее при поиске,
а потом все ячейки копировать на отдельный лист, и напротив указывать
название листа...
Возможно ли такое реализовать?

Вот то, что я смогла придумать, но, видимо, все-таки
запуталась в циклах.

Вопросы:
1) Все-таки добавляется лишний лист, вместо того,
чтобы делать проверку на лист с определенным названием,
если он существует, то удалять предыдущий и добавлять новый
2) Как осуществить снова переход на нужный лист при копировании
строчки?3)ну и названия листов я не вставила напротив каждой строчки,
а хотелось бы...

Код: Выделить всё

Private Sub Question_Find()
Dim i, j, k As Integer

'i -счетчик для листов
'j-счетчик строк в каждом листе
'k- счетчик копируемых строк

'Добавляем лист с определенным названием,
'если он существует, то удаляем предыдущий и добавляем новый

Dim xxx As Integer
    xxx = ActiveWorkbook.Worksheets.Count
For i = 1 To xxx
            If (Sheets(i).Name = "Вопросы") Then
                Application.DisplayAlerts = False
                Sheets(i).Delete
                Application.DisplayAlerts = True
                Exit For
            End If
          Next i
    ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
    ActiveWorkbook.Sheets(xxx + 1).Name = "Вопросы"
'Если цвет ячейки в первом столбце каждого листа-желтый,
'то, копируем содержимое таких ячеек на новый лист...

k = 1
For i = 1 To Sheets.Count
Sheets(i).Activate
    For j = 1 To Rows.Count
    If (Cells(j, 1).Interior.ColorIndex = 6) Then
    Rows(j).Copy
    Sheets("Вопросы").Activate
    Rows(k).Select
        ActiveSheet.Paste
        'Видимо здесь путаница....так как
        'Sheets(i).Select
        k = k + 1

    End If
    Next j

Next i
End Sub

[/i]

[GSerg]

Код: Выделить всё

Option Explicit

Sub QFind()
  Const OutSheetName As String = "Вопросы"
  Dim outSh As Excel.Worksheet
  Dim tmpSh As Excel.Worksheet, tmpCell As Excel.Range, tmpLng As Long
 
  On Error Resume Next
  Application.DisplayAlerts = False
  Worksheets(OutSheetName).Delete
  Application.DisplayAlerts = True
  On Error GoTo 0
 
  Set outSh = Worksheets.Add
  outSh.Name = OutSheetName
 
  tmpLng = 1
  For Each tmpSh In Worksheets
    If Not (tmpSh Is outSh) Then
      For Each tmpCell In tmpSh.UsedRange.Columns(1).Rows
        If tmpCell.Interior.ColorIndex = 6 Then
          tmpCell.EntireRow.Copy outSh.Cells(tmpLng, 1)
          outSh.Cells(tmpLng, 1).Insert xlShiftToRight
          outSh.Cells(tmpLng, 1).Value = tmpSh.Name
          tmpLng = tmpLng + 1
        End If
      Next
    End If
  Next
End Sub


[sonata]

Как все красиво и быстро!!!
GSerg- Вы просто моя палочка-выручалочка! Только вот еще хотелось бы добавить рядом с вопросом,наименование листа, с которого производилось копирование...

[sonata]

Код: Выделить всё

xxx = Sheets(tmpSh).Name
outSh.Cells(tmpLng, 2).Value = xxx

Так не работает-ошибочка выходит...
Вообще, законы объектного программирования плохо знаю...

[GSerg]

Всё-таки успела скопировать первую версию кода? Там вторая уже давно!

ЗЫ: последний твой пост не понял

[sonata]

I am very happy!
Жаль, здесь не предусмотрены эмоционально-восхищенно-симпатизирующие смайлики Для того, чтобы передать свои восторженно-радостные эмоции, RayShade, только не обвиняй меня в том, что я отвечаю не по существу, плиз... Я только выражаю искреннюю благодарность!!!!

[GSerg]

www.smiliki.by.ru

Секундочку, sonata, а куда ты слово kiss стёрла?