Søg i flere ark og kopier det fundne til nyt ark.

Vær opmærksom på at hvis 23:00 findes flere steder vælger koden den sidste - dette kan ændres til den første !!!

Sub tst2()
On Error Resume Next
For t = 2 To 53
If Application.CountIf(Sheets(t).Range("J5:J95"), "23:00") > 0 Then
k = Sheets(t).Range("J5:J95").Find("23:00", LookIn:=xlValues).Offset(0, 1)
h = Sheets(t).Range("J5:J95").Find("23:00", LookIn:=xlValues).Offset(0, -2)
End If
Next
MsgBox "Hvor skal den kopieres hen ? " & h
MsgBox "Hvor skal den kopieres hen ? " & k
End Sub

Stå på et tomt ark og kør så makroen, som skal være i et modul


Public Sub HentUgeark()
    Dim WS As Worksheet, RW As Long, AD As String, Res As Worksheet, Tid As Date
    Dim Data As Variant
    Tid = #11:00:00 PM#    ' 23:00
    For Each WS In Worksheets
        If IsNumeric(WS.Name) Then ' tjekker om navnet er et nummer
            Data = WS.Range("J5:L95") ' tager de 3 kolonner i en array variabel
            For i = 1 To UBound(Data) ' looper igennem til række 95
                If Format(Data(i, 1), "hh:nn:ss") = Tid Then ' tjekker op mpd tiden 23:00
                    RW = Range("A65536").End(xlUp).Row + 1 ' finder rækken under den sidst udfyldte række i til arket
                    Cells(RW, 1) = WS.Name ' skriver arknavn i A kolonnen
                    For x = 2 To 3
                        Cells(RW, x) = Data(i, x) ' skriver data fra kolonne K og L i kolonne 2 og 3
                    Next
                    Exit For
                End If
            Next
        End If
    Next
End Sub

Jeg prøver forslagene.
Glemte at sige at 23:00 vil forekomme flere steder, og det er alle forkomster der skal bruges i et andet ark..

nu skulle den tage alle.

Public Sub HentUgeark()
    Dim WS As Worksheet, RW As Long, AD As String, Res As Worksheet, Tid As Date
    Dim Data As Variant
    Tid = #11:00:00 PM#    ' 23:00
    For Each WS In Worksheets
        If IsNumeric(WS.Name) Then ' tjekker om navnet er et nummer
            Data = WS.Range("J5:L95") ' tager de 3 kolonner i en array variabel
            For i = 1 To UBound(Data) ' looper igennem til række 95
                If Format(Data(i, 1), "hh:nn:ss") = Tid Then ' tjekker op mpd tiden 23:00
                    RW = Range("A65536").End(xlUp).Row + 1 ' finder rækken under den sidst udfyldte række i til arket
                    Cells(RW, 1) = WS.Name ' skriver arknavn i A kolonnen
                    For x = 2 To 3
                        Cells(RW, x) = Data(i, x) ' skriver data fra kolonne K og L i kolonne 2 og 3
                    Next
                End If
            Next
        End If
    Next
End Sub

Denne indsætter værdierne i kolonne A og B i arket længst til venstre (1 første ark)

Sub tst2()
Set sh = Sheets(1)
On Error Resume Next
For t = 2 To 53
If Application.CountIf(Sheets(t).Range("J5:J95"), "23:00") > 0 Then
k = Sheets(t).Range("J5:J95").Find("23:00", LookIn:=xlValues).Offset(0, 1)
h = Sheets(t).Range("J5:J95").Find("23:00", LookIn:=xlValues).Offset(0, -2)

rk = sh.Cells(1000, 1).End(xlUp).Row + 1
sh.Cells(rk, 1) = h
sh.Cells(rk, 2) = k
End If
Next

End Sub

Hej Kabbak - Din ser brugbar ud. men det var kolonne H og K der skulle returneres.
Jeg har rettet til dette.

Public Sub HentUgeark()
    Dim WS As Worksheet, RW As Long, AD As String, Res As Worksheet, Tid As Date
    Dim Data As Variant
    Tid = #11:00:00 PM#    ' 23:00
    For Each WS In Worksheets
        If IsNumeric(WS.Name) Then ' tjekker om navnet er et nummer
            Data = WS.Range("G5:K95") ' tager de 3 kolonner i en array variabel
            For i = 1 To UBound(Data) ' looper igennem til række 95
                If Format(Data(i, 4), "hh:nn:ss") = Tid Then ' tjekker op mpd tiden 23:00
                    RW = Range("A65536").End(xlUp).Row + 1 ' finder rækken under den sidst udfyldte række i til arket
                    Cells(RW, 1) = WS.Name ' skriver arknavn i A kolonnen
                    For x = 2 To 5
                        Cells(RW, x) = Data(i, x) ' skriver data fra kolonne K og L i kolonne 2 og 3
                    Next
                End If
            Next
        End If
    Next
End Sub

Nu har jeg fået returneret Arknavn + kol H I J og K, kan jeg slippe for I og J.
Så er det helt perfekt.

Sub tst2()
Set sh = Sheets(1)
On Error Resume Next
For t = 2 To 53
If Application.CountIf(Sheets(t).Range("J5:J95"), "23:00") > 0 Then
k = Sheets(t).Range("J5:J95").Find("23:00", LookIn:=xlValues).Offset(0, 1)
h = Sheets(t).Range("J5:J95").Find("23:00", LookIn:=xlValues).Offset(0, -2)

rk = sh.Cells(1000, 1).End(xlUp).Row + 1
sh.Cells(rk, 1) = "Uge " & t
sh.Cells(rk, 2) = h
sh.Cells(rk, 3) = k
End If
Next

End Sub

-Excelent.
Jeg har 2 forekomster i uge 4, kun den ene returneres men til gengæld skrives den ud for resten af ugerne.

;-))

Kabbak:
havde du evt et bud på mit spg 19:56:53

Kabbak: Tak, Med et par rettelser blev din løsning helt perfekt.
        Den kom til at se sådan ud.

Public Sub HentUgeark()
    Application.ScreenUpdating = False

    Range("A2:E200").Select
    Selection.Delete

    Dim WS As Worksheet, RW As Long, AD As String, Res As Worksheet, Tid As Date
    Dim Data As Variant
    Tid = #11:00:00 PM#    ' 23:00
    For Each WS In Worksheets
        If IsNumeric(WS.Name) Then ' tjekker om navnet er et nummer
            Data = WS.Range("G5:K95") ' tager de 5 kolonner i en array variabel
            For i = 1 To UBound(Data) ' looper igennem til række 95
                If Format(Data(i, 4), "hh:nn:ss") = Tid Then ' tjekker op mpd tiden 23:00
                    RW = Range("A65536").End(xlUp).Row + 1 ' finder rækken under den sidst udfyldte række i til arket
                    Cells(RW, 1) = "Uge " & WS.Name ' skriver arknavn i A kolonnen
                    For x = 2 To 5
                        Cells(RW, x) = Data(i, x) ' skriver data fra kolonne H til K i kolonne 2 til 5
                    Next
                End If
            Next
        End If
    Next
    Range("C:D").Select
    Selection.Delete
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

Public Sub HentUgeark()
    Dim WS As Worksheet, RW As Long, AD As String, Res As Worksheet, Tid As Date
    Dim Data As Variant
    Tid = #11:00:00 PM#    ' 23:00
    For Each WS In Worksheets
        If IsNumeric(WS.Name) Then    ' tjekker om navnet er et nummer
            Data = WS.Range("H5:K95")    ' tager de 3 kolonner i en array variabel
            For i = 1 To UBound(Data)    ' looper igennem til række 95
                If Format(Data(i, 3), "hh:nn:ss") = Tid Then    ' tjekker op mpd tiden 23:00
                    RW = Range("A65536").End(xlUp).Row + 1    ' finder rækken under den sidst udfyldte række i til arket
                    Cells(RW, 1) = WS.Name    ' skriver arknavn i A kolonnen
                    Cells(RW, 2) = Data(i, 1)    ' skriver data fra kolonne H i kolonne 2
                    Cells(RW, 3) = Data(i, 4) ' skriver data fra kolonne K i kolonne 3
                End If
            Next
        End If
    Next
End Sub

Kabbak:
Perfekt  :-)