archivio CD

[raimea]

ciao
sto realizzando un semplice file per l' archivio musicale di CD
sono a buon punto, mi servirebbe aiuto per la parte della ricerca.

in fgl cerca
scrivo in D4 la parola o parte di parola da cercare in fgl elenco,
andando a cercarla in tutte e 5 le colonne da D7:H
e riportare i risultati in fgl cerca da riga D7

ES:
se scrivo vasco
dovra' riportarmi tutto cio che contiene.
vasco
oppure solo ..sco

spero di essermi spiegato

vi allego il file

https://www.dropbox.com/scl/fi/m4y7eo4lx7oquzt59dzp9/archivio_cd.xlsm?rlkey=x06hm6i6n3sfbi8lrnfd3biji&st=wksmsoo3&dl=0

ciao

[Raffaele53]

Da provare

Codice: Seleziona tutto

Option Explicit
Option Compare Text
Sub Cerca()
Dim F1 As Worksheet: Set F1 = Worksheets("Elenco")
Dim F2 As Worksheet: Set F2 = Worksheets("cerca")
Dim Ur As Long, X As Long, Rg As Long, Rr As Long, Rx As Long, Txt As String
Ur = F2.Range("D" & Rows.Count).End(xlUp).Row
If Ur > 6 Then F1.Range("D7:H" & Ur) = ""
Ur = F1.Range("D" & Rows.Count).End(xlUp).Row
Txt = F2.Range("D4")
If Txt = "" Then Exit Sub
Rr = 7
Rg = Rr
F1.Activate
    For X = 7 To Ur
        F1.Range("D" & X).Activate
        F1.Cells.Find(What:=Txt, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
        Rx = Selection.Row
        If Rg <> Rx Then
            F1.Range(F1.Cells(Rx, "D"), F1.Cells(Rx, "H")).Copy
            F2.Range("D" & Rr).PasteSpecial
            Rg = Rx
            Rr = Rr + 1
            X = Rx + 1
        End If
    Next
F2.Activate
Set F1 = Nothing
Set F2 = Nothing
End Sub

[Anthony47]

Probabilmente Raffaele (ciao!) ti sta proponendo una soluzione piu' adeguata alla tua richiesta (vedi messaggio prima di questo mio).

Io in prima battuta ti manderei a provare il metodo presentato in questo file sviluppato tempo fa per altro utente:
https://www.dropbox.com/scl/fi/y6qy169d ... tt7kw&dl=0

In particolare, parti da Foglio1 e premi “Show Form”
Ti verra’ aperta una userform che contiene un ListBox a 5 colonne e un textbox che contiene tutte le righe di quel foglio. Man mano che scrivi qualcosa nel textbox nel listbox saranno mostrate solo le righe che in una delle 5 colonne contengono la stringa digitata. Inoltre e’ possibile, tramite una serie di radiobutton, scegliere quale colonna ordinare.
Infine un pulsante OK scrive i risultati filtrati nella posizione predeterminata (io ho impostato Foglio2!D5)

La posizione del database e la posizione di scrittura sono da impostare nella Sub UserForm_Initialize (le tre righe marcate <<<)

Se vuoi prova e fai sapere...

[raimea]

ciao
la soluzione raffaele
Non va bene
mi riporta solo la prima riga che trova
e non tutte le righe con stessa parola/frase

inoltre se scrivo CD
sembra vada in loop e non si ferma piu
------
ora se riesco applico al mio file
la prova indicata da antony

faccio sapere
grazie


EDIT:
errore mio , non e vero che:

mi riporta solo la prima riga che trova
e non tutte le righe con stessa parola/frase

[raimea]

ciao
sono riuscito a importare la useform ecc.. "show form"
e a farla funzionare.

sono a chiedere come migliorarla in 2 cose.

1_pulire tutto il foglio di destinazione "cerca"
prima di scriverci i nuovi dati.

2_ al preme del pulsante OK nella useform
portarmi direttamente nel fgl cerca.

vi allego il file aggiornato

https://www.dropbox.com/scl/fi/gzlp6710doq58p5r8b12o/archivio_cd_V2.xlsm?rlkey=lqb175bk42sujg4ic2slo08uf&st=69m0105r&dl=0

grazie

[Anthony47]

Si puo' fare in vari modi, ad esempio lavorando sulla Sub CB1_Click, che comunque e' da modificare perche' mi sono accorto che se il risultato e' su 1 sola riga l'output viene sbagliato. Il nuovo codice:

Codice: Seleziona tutto

Private Sub CB1_Click()
oPos.Resize(10000, 5).Clear             '.ClearContents ??
If UBound(sArr, 2) > 1 Then
    oPos.Resize(UBound(sArr), UBound(sArr, 2)).Value = sArr
Else
    oPos.Resize(UBound(sArr, 2), UBound(sArr)).Value = Application.WorksheetFunction.Transpose(sArr)
End If
Application.Goto Sheets("cerca").Range("D6")
'Unload Me                     ' VEDI TESTO
End Sub

Se col pulsante OK si vuole anche chiudere la userform allora bisogna "scommentare" (cioe' togliere l'apostrofo a inizio riga) l'istruzione Unload Me

[raimea]

ciao
tutto ok

si mi ero accorto del problema
nel caso ci fosse stato una sola riga da mettere nel fgl cerca

se il risultato e' su 1 sola riga l'output viene sbagliato

proseguo con i test

grazie

[Ricky0185]

Prova questo, non penso tu abbia problemi ad adattarlo. Grande Ennius

[raimea]

ciao >> ricy0185

grazie dell' indicazione.

questa vers. la conosco
e' quella che ho usato per un po' di tempo.
e' molto piu completa.

MA
questa volta sto facendo il lavoro per un ragazzo
al quale serve una vers. il piu semplice possibile.

ancora grazie a tutti e 3

ciao

[Raffaele53]

>>>inoltre se scrivo CD sembra vada in loop e non si ferma piu

Codice: Seleziona tutto

Option Explicit
Option Compare Text
Sub Cerca()
Dim F1 As Worksheet: Set F1 = Worksheets("Elenco")
Dim F2 As Worksheet: Set F2 = Worksheets("cerca")
Dim Ur As Long, X As Long, Rg As Long, Rr As Long, Rx As Long, Txt As String
Ur = F2.Range("D" & Rows.Count).End(xlUp).Row
If Ur > 6 Then F2.Range("D7:H" & Ur).Clear
Ur = F1.Range("D" & Rows.Count).End(xlUp).Row
Txt = F2.Range("D4")
If Txt = "" Then Exit Sub
Rr = 7
Rg = Rr
Application.ScreenUpdating = False
F1.Activate
    For X = 7 To Ur
        F1.Range("D" & X).Activate
        F1.Cells.Find(What:=Txt, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
        Rx = Selection.Row
        If Rg <> Rx Then
            If Rx < Rg Then GoTo Fine
            F1.Range(F1.Cells(Rx, "D"), F1.Cells(Rx, "H")).Copy
            F2.Range("D" & Rr).PasteSpecial
            Rg = Rx
            Rr = Rr + 1
            X = Rx
        End If
    Next
Fine:
F2.Activate
Application.ScreenUpdating = True
Set F1 = Nothing
Set F2 = Nothing
MsgBox "Fatto"
End Sub

[raimea]

ciao Raffaele

ho provato anche la tua 2da vers.
ora e' quasi al 100%

serve gestire casi in cui non trova nulla
in nessuna delle 5 colonne nel fgl elenco.

attualmente va in tilt
ES se scrivo in D4 888 anzicche' 883

ciao

[Raffaele53]

Prova

Codice: Seleziona tutto

Option Explicit
Option Compare Text
Sub Cerca2()
Dim F1 As Worksheet: Set F1 = Worksheets("Elenco")
Dim F2 As Worksheet: Set F2 = Worksheets("cerca")
Dim Ur As Long, X As Long, Rr As Long, Ri As Long, Rx As Long, Txt As String, Rg As Object
Ur = F2.Range("D" & Rows.Count).End(xlUp).Row
If Ur > 6 Then F2.Range("D7:H" & Ur).Clear
Ur = F1.Range("D" & Rows.Count).End(xlUp).Row
Txt = F2.Range("D4")
If Txt = "" Then MsgBox "Inserisci una parola in D4": Exit Sub
Ri = 7
Rr = 7
    For X = 7 To Ur
        Set Rg = F1.Range("D" & Ri & ":H" & Ur).Find(Txt, LookIn:=xlValues, LookAt:=xlPart)
        If Rg Is Nothing Then
            GoTo Fine
        Else
            Rx = Rg.Row
            F1.Range(F1.Cells(Rx, "D"), F1.Cells(Rx, "H")).Copy
            F2.Range("D" & Rr).PasteSpecial
            Rr = Rr + 1
            Ri = Rx + 1
            X = Rx
        End If
    Next
Fine:
Set F1 = Nothing
Set F2 = Nothing
Set Rg = Nothing
MsgBox "Fatto"
End Sub