ricerca

Versione Completa   Stampa   Cerca   Utenti   Iscriviti     Condividi : FacebookTwitter
Salvatore Vicari
00giovedì 28 gennaio 2016 14:22
Ricercare date uguali in piu fogli risultato in un altro foglio
alfrimpa
00giovedì 28 gennaio 2016 14:39
Buona giornata Salvatore

Considerato che le parole non si pagano avresti potuto spenderne qualcuna in più per spiegare meglio il tuo quesito/problema.

Allega un file di Excel di esempio con la situazione di partenza ed il risultato che vuoi ottenere.
Salvatore Vicari
00giovedì 28 gennaio 2016 17:19
RIEPILOGO PARTITE DIO OGGI
Scusa se non sono stato cosi chiaro che spiegare la cosa.
Volevo realizzare un foglio dove ci sono le giornate di campionato
di calcio serie A,B,C ecc.
Volevo che in un altro Foglio ci sia un riepilogo del partite di una determinata Data.
Spero che sia stato chiaro.
allego File Excel
Grazie

Salvatore
raffaele1953
00giovedì 28 gennaio 2016 22:20
Apri foglio "Oggi Giocano" e premi Alt+F11 (incolla sulla destra)
Chiudi e salva come nome.XLXM
Ogni volta che cambi data compila la lista.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("F1")) Is Nothing Then
        Application.EnableEvents = False
        Dim Ur, Ur1, Rg, X, DD As Date
        DD = Range("F1")
        Rg = 2
        If Not IsDate(Range("F1")) Or Range("F1") = "" Then GoTo Fine
            Ur = Sheets("OGGI GIOCANO").Range("A" & Rows.Count).End(xlUp).Row
            If Ur > 1 Then Sheets("OGGI GIOCANO").Range("A2:C" & Ur).ClearContents
            Ur = Sheets("GIRONE A").Range("A" & Rows.Count).End(xlUp).Row
            For X = 2 To Ur
                If Sheets("GIRONE A").Cells(X, 1) = Range("F1") Then
                    Sheets("GIRONE A").Range(Sheets("GIRONE A").Cells(X, 1), Sheets("GIRONE A").Cells(X, 3)).Copy
                    Sheets("OGGI GIOCANO").Cells(Rg, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Rg = Rg + 1
                End If
            Next X
            Ur = Sheets("GIRONE B").Range("A" & Rows.Count).End(xlUp).Row
            For X = 2 To Ur
                If Sheets("GIRONE B").Cells(X, 1) = Range("F1") Then
                    Sheets("GIRONE B").Range(Sheets("GIRONE B").Cells(X, 1), Sheets("GIRONE B").Cells(X, 3)).Copy
                    Sheets("OGGI GIOCANO").Cells(Rg, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Rg = Rg + 1
                End If
            Next X
    End If
Fine:
Application.EnableEvents = True
End Sub
G.Panella
00venerdì 29 gennaio 2016 13:03
grazìe
Salvatore Vicari
00venerdì 29 gennaio 2016 13:35
Troppo Permaloso,
Grazie della soluzione, Per lavoro non ho risposto prima e non avevo ancora provato. [SM=g27811] scusa e Grazie.
m4tteo.
00venerdì 29 gennaio 2016 13:59
GRAZIE
GRAZIE
cgentile700
00venerdì 29 gennaio 2016 16:37
info
si potrebbe generalizzare la routine nel senso che nel file non so quanti fogli ci siano quindi scorrere tutti i fogli tranne oggi giocano e prendere tutte le occorrenze che rispettano il valore nella cella f1.

grazie in anticipo
raffaele1953
00venerdì 29 gennaio 2016 18:14
>>>si potrebbe generalizzare la routine

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("F1")) Is Nothing Then
        Application.EnableEvents = False
        Dim Ur, Ur1, Rg, X, Ws As Worksheet
        Rg = 2
        If Not IsDate(Range("F1")) Or Range("F1") = "" Then GoTo Fine
            Ur = Sheets("OGGI GIOCANO").Range("A" & Rows.Count).End(xlUp).Row
            If Ur > 1 Then Sheets("OGGI GIOCANO").Range("A2:C" & Ur).ClearContents
            For Each Ws In ActiveWorkbook.Worksheets
                If Ws.Name <> "OGGI GIOCANO" Then ''qui il nome
                Ur = Ws.Range("A" & Rows.Count).End(xlUp).Row
                For X = 2 To Ur
                    If Ws.Cells(X, 1) = Sheets("OGGI GIOCANO").Range("F1") Then
                        Ws.Range(Ws.Cells(X, 1), Ws.Cells(X, 3)).Copy
                        Sheets("OGGI GIOCANO").Cells(Rg, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                        Rg = Rg + 1
                    End If
                Next X
            End If
            Next Ws
    End If
Fine:
Application.EnableEvents = True
End Sub
Questa è la versione 'lo-fi' del Forum Per visualizzare la versione completa clicca qui
Tutti gli orari sono GMT+01:00. Adesso sono le 23:34.
Copyright © 2000-2024 FFZ srl - www.freeforumzone.com