Gegevens verzamelen uit Workbook

[Bergsma1]

Ik zoek een script dat eningszins efficient werkt om het volgende te bewerkstelligen.

Op tabblad Summary (zie bijlage) zou ik graag zien dat een lijst wordt gemaakt van alle cellen die in het Workbook staan en beginnen met de volgende karakters
NA, NP of K

Dus cellen met de waarde
NAX wel
ANAX niet
KXXX WEL
nPK WEL
NXK NIET

De waarden komen uit alle sheets in een workbook (het orginele workbook bevat meer dan 100+ sheets) en staan random in een vast zoekbereik tot en met Rij 1200 en Kolom 90

Graag zou ik na het vinden van de waarden ook nog willen zien van welk tabblad de waarde afkomstig is.

Zie het voorbeeldbestand.

 

[OctaFish]

Hiermee moet het wel lukken.

Sub mcrRange()
Dim sht As Worksheet, shtTarget As Worksheet
Dim rng As Range, cel As Range
Dim lRow As Long, i As Long, j As Long
    
    Set shtTarget = Sheets("SUMMARY")
    lRow = 1
    For Each sht In ActiveWorkbook.Worksheets
        If LCase(Left(sht.Name, 5)) = "sheet" Then
            Set rng = Range(sht.Cells(1, 1), sht.Cells(1, 1).SpecialCells(xlLastCell))
            arr = rng
            For Each cel In rng
                If Left(cel.Value, 2) = "NA" Or Left(cel.Value, 2) = "NP" Or Left(cel.Value, 1) = "K" Then
                    shtTarget.Cells(lRow, 1).Value = cel.Value
                    shtTarget.Cells(lRow, 2) = sht.Name
                    lRow = shtTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1
                End If
            Next cel
        End If
    Next sht

End Sub

In ieder geval heb je een begin .

 

[VenA]

Zo ook wel. En niet hooffdletter gevoelig.

Sub VenA()
  With Sheets("SUMMARY")
    For Each sh In Sheets
      If sh.Name <> .Name Then
        On Error Resume Next
        For Each cl In sh.Cells.SpecialCells(2)
          If InStr(1, "NANP", Left(cl, 2), 1) Or LCase(Left(cl, 1)) = "k" Then .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3) = Array(cl, sh.Name, cl.Address)
        Next cl
      End If
    Next sh
  End With
End Sub

Je kan de gegevens ook eerst verzamelen in een array. Dan gaat het wegschrijven wat sneller.

 

[Bergsma1]

Onderste script werkt!

 

[snb]

Sub M_snb()
  ReDim sp(Rows.Count - 1, 0)
    
  For Each it In Sheets
    For Each it1 In it.Cells.SpecialCells(2, 2)
      If (InStr(1, "_" & it1, "_NX", 1) Or InStr(1, "_" & it1, "_NA", 1) Or InStr(1, "_" & it1, "_K", 1)) And it.CodeName <> Sheet1.CodeName Then
        sp(y, 0) = it1 & "_" & it.Name
        y = y + 1
      End If
    Next
  Next
    
  Sheet1.Cells(1, 4).Resize(y) = sp
End Sub