Excel Поиск VBA macro

Question

Мне задали задачу поиска по большому объему данных. Данные представляются одинаково примерно на 50 листах. I нужен макрос, который выполняет поиск по всем этим листам для определенных значений , а затем копирует определенные ячейки в таблицу, созданную в новой книге. Макрос также должен создавать заголовки таблиц при его запуске.

Он должен Search column G For the Value 9.1 Тогда определенная информация должна быть скопирована в соответствующие столбцы в таблице

• ФКИ Ссылка = То же значение, строка из колонки G
• Эффекта двигателя = То же значение, строки из колонки F
• Номер детали = всегда ячейка J3
• Наименование части = всегда ячейка C2
• FM ID = одинаковое значение строки из столбца B
• Failure Mode & Причина = тот же строка значения из столбца C
• FMCN = тот же строка значения из колонки C "`

Если это хлопоты, чтобы создать новую книгу с этими колонками заголовков, то я бы очень довольны созданием заголовков в листе и просто найдите макрос и скопируйте данные в строки, соответствующие заголовкам.

Если вам нужна помощь или резервные копии файлов, я был бы более чем счастлив, если бы предоставить эти.

код у меня есть на данный момент на основе UserForm и в идеале я бы покончить с этим и просто найти все листы

Public Sub createWSheet(module, srcWBook) 
     Dim i 

     i = 0 
     srcWB = srcWBook 
     For Each ws In Workbooks(srcWBook).Worksheets 
      i = i + 1 
      If ws.Name = module Then 
       MsgBox ("A worksheet with for this module already exists") 
       Exit Sub 
      End If 
     Next ws 

     Workbooks(srcWBook).Activate 
     Worksheets.Add after:=Worksheets(i) 
     ActiveSheet.Name = module 
     Cells(2, 2) = "FHA Ref" 
     Cells(2, 3) = "Engine Effect" 
     Cells(2, 4) = "Part No" 
     Cells(2, 5) = "Part Name" 
     Cells(2, 6) = "FM ID" 
     Cells(2, 7) = "Failure Mode & Cause" 
     Cells(2, 8) = "FMCN" 
     Cells(2, 9) = "PTR" 
     Cells(2, 10) = "ETR" 

     Range(Cells(2, 2), Cells(2, 10)).Font.Bold = True 
     Range(Cells(1, 2), Cells(1, 10)) = "Interface" 
     Range(Cells(1, 2), Cells(1, 10)).MergeCells = True 
     Range(Cells(1, 2), Cells(1, 10)).Font.Bold = True 
     Workbooks(srcWBook).Activate 
    End Sub 
Dim mainWB, srcWBook 
Dim headerLeft, headerTop, headerBottom, headerRight 
Dim nTargetFMECA, nPartID, nLineID, nPartNo, nPartName, nQTY, nFailureMode, nAssumedSystemEffect, nAssumedEngineEffect 
Dim item As String 
Dim mDest 
Dim selections(100) 


Public Sub controlCopyFMs(mWB, sWB, module) 
    Dim i 

    mainWB = mWB 
    srcWBook = sWB 
    mDest = 2 

    nTargetFMECA = 0 
    nPartID = 0 
    nLineID = 0 
    nPartNo = 0 
    nPartName = 0 
    nQTY = 0 
    nFailureMode = 0 
    nAssumedSystemEffect = 0 
    nAssumedEngineEffect = 0 

    For i = 0 To TestForm.LBSelected.ListCount - 1 
     Call copyFMs(module, selections(i)) 
    Next i 
End Sub 




    Public Sub copyFMs(module, comp) 
     Dim mSrc 

     Workbooks(srcWBook).Sheets(comp).Select 
     If exploreHeader(comp) = 0 Then 
      Exit Sub 
     End If 

     mSrc = headerBottom + 3 

     While Cells(mSrc, nSrc).Text <> "" 
      If Cells(mSrc, nIndication).Text <> "-" Then 
       If Cells(mSrc, nIndication).Text <> "" Then 
        Workbooks(mainWB).Worksheets(module).Cells(mDest, 2) = Cells(mSrc, nTargetFMECA).Value 
        Workbooks(mainWB).Worksheets(module).Cells(mDest, 3) = Cells(mSrc, nPartID).Value 
        Workbooks(mainWB).Worksheets(module).Cells(mDest, 4) = Cells(mSrc, nLineID).Value 
        Workbooks(mainWB).Worksheets(module).Cells(mDest, 5) = Cells(mSrc, nPartNo).Value 
        Workbooks(mainWB).Worksheets(module).Cells(mDest, 6) = Cells(mSrc, nPartName).Value 
        Workbooks(mainWB).Worksheets(module).Cells(mDest, 7) = Cells(mSrc, nQTY).Value 
        Workbooks(mainWB).Worksheets(module).Cells(mDest, 8) = Cells(mSrc, nFailureMode).Value 
        Workbooks(mainWB).Worksheets(module).Cells(mDest, 9) = Cells(mSrc, nAssumedEngineEffect).Value 
        Workbooks(mainWB).Worksheets(module).Cells(mDest, 10) = Cells(mSrc, nAssumedSystemEffect).Value 
        mDest = mDest + 1 
       End If 
      End If 
      mSrc = mSrc + 2 
     Wend 
    End Sub 



    Public Function exploreHeader(comp) 
     Dim m, n 

     m = 1 
     n = 1 

     While ((InStr(1, Cells(m, n).Text, "Engine Programme:", vbTextCompare) <= 0) Or (InStr(1, Cells(m, n).Text, "BR700-725", vbTextCompare) <= 0)) And n < 10 
      If m < 10 Then 
       m = m + 1 
      Else 
       n = n + 1 
       m = 1 
      End If 
     Wend 

     headerTop = m 
     headerLeft = n 

     While StrComp(Cells(m, n).Text, "ID", vbTextCompare) <> 0 And StrComp(Cells(m, n).Text, "Case No.", vbTextCompare) <> 0 
      m = m + 1 
     Wend 
     headerBottom = m - 1 

     While Cells(m, n).Borders(xlEdgeBottom).LineStyle = xlContinuous 
      n = n + 1 
     Wend 
     headerRight = n - 1 

     m = headerTop 
     n = headerLeft 
     Do 
      If n > headerRight Then 
       n = headerLeft 
       m = m + 1 
      End If 

      If InStr(1, Cells(m, n).Value, "Item No.:", vbTextCompare) > 0 Then 
       item = Right(Cells(m, n).Value, Len(Cells(m, n).Value) - InStr(1, Cells(m, n).Value, ":", vbTextCompare)) 
       Cells(m, n).Select 
       Exit Do 
      End If 

      n = n + 1 
     Loop While m <= headerBottom 

     m = headerBottom + 1 
     n = headerLeft 
     While n <= headerRight 
      If StrComp(Cells(m, n).Value, "ID", vbTextCompare) = 0 Then 
       nID = n 
      End If 

      If StrComp(Cells(m, n).Value, "Mitigation", vbTextCompare) = 0 Then 
       nMitigation = n 
      End If 

      If StrComp(Cells(m, n).Value, "Remarks", vbTextCompare) = 0 Then 
       nRemarks = n 
      End If 

      If StrComp(Cells(m, n).Value, "FMCN", vbTextCompare) = 0 Then 
       nFMCN = n 
      End If 

      If StrComp(Cells(m, n).Value, "Indication", vbTextCompare) = 0 Then 
       nIndication = n 
      End If 

      If StrComp(Cells(m, n).Value, "Crit", vbTextCompare) = 0 Then 
       nFMCN = n 
      End If 

      If StrComp(Cells(m, n).Value, "Detect", vbTextCompare) = 0 Then 
       nIndication = n 
      End If 

      If StrComp(Cells(m, n).Value, "Functional Description", vbTextCompare) = 0 Then 
       nMitigation = n 
      End If 

      n = n + 1 
     Wend 
     exploreHeader = 1 
    End Function 


    Public Sub initSelections() 
     For i = 0 To 99 
      selections(i) = "" 
     Next i 
    End Sub 


    Public Sub loadSelection(comp, i) 
     selections(i) = comp 
    End Sub 



    Public Sub deleteSelection(i) 
     While selections(i) <> "" 
      selections(i) = selections(i + 1) 
      i = i + 1 
     Wend 
    End Sub 

Answer 1

Я надеюсь, что это может помочь больше. Этот код может не работать на 100%, но он должен быть достаточно хорошим, чтобы вести вас. Дайте мне знать, если у вас есть вопросы.

Dim WS As Worksheet 
Dim Results(7, 1000000) As String ''Didn't know what is a good data type or how many possible results 
Dim ColValue() As Variant 
Dim I, II, ResultCt As Long 


ResultCt = 0 

For Each WS In ActiveWorkbook.Worksheets ''This should get all your result and information into the Results Array 

    ColValue = ActiveSheet.Range(Cells(2, 7), Cells(WS.UsedRange.Rows.Count, 7)).Value ''This put all of column G into an array 

    For I = 0 To UBound(ColValue) 
     If ColValue(I, 1) = "9.1" Then 
      Results(0, ResultCt) = Cells(I + 1, 7).Value ''I think it is off by 1, but if not remove the +1 
      Results(1, ResultCt) = Cells(I + 1, 6).Value 
      Results(2, ResultCt) = Cells(3, 10).Value 
      Results(3, ResultCt) = Cells(2, 3).Value 
      Results(4, ResultCt) = Cells(I + 1, 2).Value 
      Results(5, ResultCt) = Cells(I + 1, 3).Value 
      Results(6, ResultCt) = Cells(I + 1, 3).Value 
      ResultCt = ResultCt + 1 
     End If 
    Next 

Next WS 

«» На данный момент нам код, чтобы создать лист и назовите его «», начиная от линии Workbooks (srcWBook) .Activate

«» Затем установите активную ячейку туда, где когда-либо вам хотят, чтобы начать ввод данных и иметь что-то вроде

For I = 0 To UBound(Results, 2) 
    For II = 0 To UBound(Results) 
     ActiveCell.Offset(I, II).Value = Results(I, II) ''This assumes you put the information into Result in the order you want it printed out 
    Next 
Next