Прочитать данные из Excel

[viter.alex]

Есть таблица в файле. В столбцах M-N есть заголовки. Нужно прочитать фамилии, напротив которых в этих столбцах стоят 1. Можно сделать хотя бы для одного столбца, а дальше я сам.
Массив с именами заголовков задается как

Headers = Array ("руководителю работ", "производителю работ", _
              "допускающему", "с членами бригады", "фамилия", "наблюдающему")

И еще нужно прочитать инициалы из ячейки под фамилией и группу по ТБ. Можно все это записать в массив, запись должна иметь вид: Фамилия И.О. гр. 3
Сделать это макросом. Мне хотя бы наметку, как это делать. Адрес столбца я вытащу, а дальше путаюсь в этих диапазонах

[EducatedFool]

Попробуй так:

Sub test()
    Application.ScreenUpdating = False
    Dim cell As Range: Set cell = [c9]
    While cell <> ""
        Column13value = cell.EntireRow.Cells("13")
        If Column13value = 1 Then
            ФИО = cell & " " & cell.Offset(1)
            ТабНомер = "Таб. номер " & cell.Previous
            ТБ = "Группа по ТБ " & cell.Next.Next
            Debug.Print ФИО, ТБ, ТабНомер
        End If
        Set cell = cell.Offset(2)
    Wend
End Sub

[viter.alex]

ОК, будем думать.

Попробовал
Выделенная строка не принимает адрес столбца в виде строки. Что делать?

Sub extractdata()
  Dim i As Long
  Dim sCol As String
  sColumns = Array("руководителю работ", "производителю работ", _
    "допускающему", "с членами бригады", "фамилия", "наблюдающему")
  Dim sColNum As String 'адрес столбца с нужной записью
    Application.ScreenUpdating = False
    Dim oCell As Range: Set oCell = [c9]
   For i = 0 To UBound(sColumns)
     sColNum = Mid(Rows(3).Find(sColumns(i)).Address, InStrRev(Cells.Find(col).Address, "$") - 1, 1)
    Column13value = oCell.EntireRow.Cells(sColNum)
    While oCell <> ""
      If Column13value = 1 Then
        ФИО = cell & " " & cell.Offset(1)
        ТабНомер = "Таб. номер " & cell.Previous
        ТБ = "Группа по ТБ " & cell.Next.Next
        Debug.Print sColumns(i), ФИО, ТБ, ТабНомер
      End If
      Set cell = cell.Offset(2)
    Wend
  Next i
End Sub

Еще раз подумал
Но может быть есть более простой метод?

    sColNum = Mid(Rows(3).Find(sColumns(i)).Address, InStrRev(Cells.Find(col).Address, "$") - 1, 1)
    sRowNum = Mid(oCell.Address, InStrRev(oCell.Address, "$") + 1, 1)
    Column13value = Range(sColNum & sRowNum)

[viter.alex]

Вот такой рабочий вариант, только мне не нравится метод определения номера столбца и строки

Sub extractdata()
  Dim i As Long
  Dim sCol As String
  sColumns = Array("руководителю работ", "производителю работ", _
    "допускающему", "с членами бригады", "фамилия", "наблюдающему")
  Dim sColNum As String 'адрес столбца с нужной записью
  Dim sRowNum As String
  Application.ScreenUpdating = False
  Dim oCell As Range
  For i = 0 To UBound(sColumns)
    Set oCell = [c9]
    sColNum = Rows(3).Find(sColumns(i)).Address
    sColNum = Mid(sColNum, InStr(sColNum, "$") + 1, InStrRev(sColNum, "$") - InStr(sColNum, "$") - 1)
    While oCell <> ""
      sRowNum = Mid(oCell.Address, InStrRev(oCell.Address, "$") + 1)
      If Range(sColNum & sRowNum) = 1 Then
        ФИО = Trim(oCell) & " " & Trim(oCell.Offset(1))
        ТБ = "Группа по ТБ " & oCell.Next.Next
        Debug.Print sColumns(i), ФИО, ТБ, ТабНомер
      End If
      Set oCell = oCell.Offset(2)
    Wend
  Next i
End Sub

[SAS888]

Что-то я запутался в Вашем коде. Что Вы хотите? Так, например, для столбца "M" сформировать массив из элементов, которые оговорены в посте №1

запись должна иметь вид: Фамилия И.О. гр. 3

можно так:

Sub Main()
    Dim i As Long, j As Long, a()
    ReDim a(0): j = 0
    For i = 9 To Cells(Rows.Count, "M").End(xlUp).Row
        If Cells(i, "M") = 1 Then
            a(j) = Cells(i, "C") & " " & Acr(Cells(i + 1, "C")) & " гр. " & Cells(i, "E")
            ReDim Preserve a(UBound(a) + 1): j = j + 1
        End If
    Next
    ReDim Preserve a(UBound(a) - 1)
End Sub

Function Acr(text) As String
    Dim TextLen As Integer, k As Integer
    text = Application.Trim(text): TextLen = Len(text): Acr = Left(text, 1) & "."
    For k = 2 To TextLen
        If Mid(text, k, 1) = Chr(32) Then Acr = Acr & Mid(text, k + 1, 1)
    Next
    Acr = UCase(Acr)
End Function

В результате получим одномерный массив "a" с требуемыми элементами.
Если нужно, организуйте цикл по столбцам, содержащим заголовки из Вашего массива. Так же можно повставлять различные проверки (или просто игнорировать возможные ошибки).

[SAS888]

Может быть нужно получить уникальный список фамилий, инициалов и номеров групп из столбцов с заданными массивом заголовками, в строках которых есть "1" ? Тогда можно так:

Sub Main()
    Dim i As Long, j As Long, y As Range, z As New Collection, x, a()
    sColumns = Array("руководителю работ", "производителю работ", _
        "допускающему", "с членами бригады", "фамилия", "наблюдающему")
    ReDim a(0): j = 0
    For Each x In sColumns
        Set y = Rows(3).Find(x, LookAt:=xlWhole)
        If Not y Is Nothing Then
            For i = 9 To Cells(Rows.Count, y.Column).End(xlUp).Row
                If Cells(i, y.Column) = 1 Then
                    a(j) = Cells(i, "C") & " " & Acr(Cells(i + 1, "C")) & " гр. " & Cells(i, "E")
                    On Error Resume Next
                    z.Add a(j), CStr(a(j))
                    If Err = 0 Then
                        ReDim Preserve a(UBound(a) + 1): j = j + 1
                    Else: On Error GoTo 0
                    End If
                End If
            Next
        End If
    Next
    ReDim Preserve a(UBound(a) - 1)
    
'Для наглядности, выведем полученный список:

    For i = 0 To UBound(a)
        Msg = Msg & a(i) & vbCrLf
    Next
    MsgBox Msg
        
End Sub

Function Acr(text) As String
    Dim TextLen As Integer, k As Integer
    On Error Resume Next
    text = Application.Trim(text): TextLen = Len(text): Acr = Left(text, 1) & "."
    For k = 2 To TextLen
        If Mid(text, k, 1) = Chr(32) Then Acr = Acr & Mid(text, k + 1, 1)
    Next
    Acr = UCase(Acr)
End Function

[viter.alex]

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

[SAS888]

Если не затруднит, укажите, какие ошибки.