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


[raimea]

ciao
Raffaele >> tutto ok

lascero' nel file, entrambi i modi di ricerca
perche' sono entrambi OTTIMI

grazie

[raimea]

ciao
in fgl film quando premo cerca_2
attivo la useform1

di useform1
in autonomia sono riuscito ad adattare
parecchie cose ma questo non riesco a sistemarlo.

non riesco a mettere in ordine crescente le date
di col D di fgl film

quando spunto il relativo cerchietto
che fa riferimento ad >> optionbutton2
vorrei mettesse in ord crescente le date.

vi allego il file
grazie
ciao

https://www.dropbox.com/scl/fi/29bavx7d ... oab2c&dl=0

[Anthony47]

La procedura bbSort lavora su stringhe, non su “data”

Per farle gestire le date bisogna fare alcuni interventi:
-definire una variabile noSort as Boolean a livello di modulo, usata per bloccare la bbSort durante la inizializzazione della form
-bisogna rimediare al fatto che, nella Transpose, il vba copi i valori non (anche) il tipo dati

In codice:
1) Riga Modificata con l’aggiunta di noSort:

Codice: Seleziona tutto

Private sArr(), iSort As Long, noSort As Boolean            'MMMM


2) Procedura modificata:

Codice: Seleziona tutto

Private Sub UserForm_Initialize()               'MMMMM
Dim sArr(), SRan As Range
'
noSort = True
'
Set DBBase = Sheets("film").Range("D8")      '<<< L'inizio del database
DBLargh = 6                                     '<<< Quante colonne esaminare
Set oPos = Sheets("cerca").Range("D7")        '<<< Dove scrivere i risultati filtrati
'
Set SRan = Range(DBBase, DBBase.End(xlDown).Offset(0, DBLargh - 1))         'This is the Row Source
Me.OptionButton1 = True
'Set SRan = Range(Range("B2"), Range("B2").End(xlDown).End(xlToRight))
ReDim sArr(1 To SRan.Rows.Count, 1 To SRan.Columns.Count)
sArr = SRan.Value
sArr = bbSort(sArr)

Me.ListBox1.List = sArr
noSort = False
End Sub


3) Procedura modificata:

Codice: Seleziona tutto

Function bbSort(ByVal lArr) As Variant          'MMMM
Dim tTmp
If noSort Or Me.TextBox1.Value = " " Then bbSort = lArr: Exit Function   'exit senza Sort
'Ripristina typenames:
For i = LBound(sArr) To UBound(sArr)
    For j = LBound(sArr, 2) To UBound(sArr, 2)
        lArr(j, i) = sArr(i, j)
    Next j
Next i
'
On Error Resume Next
UB2 = UBound(lArr, 2)
On Error GoTo 0
If iSort < 50 And UB2 > 1 Then
    lb0 = LBound(lArr)
    For i = lb0 To UBound(lArr) - 1
        For j = i + 1 To UBound(lArr)
            If (lArr(i, lb0 + iSort)) > (lArr(j, lb0 + iSort)) Then    'eliminato UCase !!
                For k = LBound(lArr, 2) To UBound(lArr, 2)
                    tTmp = lArr(j, k)
                    lArr(j, k) = lArr(i, k)
                    lArr(i, k) = tTmp
                Next k
            End If
        Next j
    Next i
End If
bbSort = lArr
End Function


Sinceramente e' diventato poco lineare, trattandosi di una realizzazione fatta per un utente, adattata per un altro, modificata per un altro, adattata per te... Insomma alla prossima revisione mi converrà ripensare tutto!

[raimea]

ciao
tutto ok

Sinceramente e' diventato poco lineare, trattandosi di una realizzazione fatta per un utente, adattata per un altro, modificata per un altro, adattata per te... Insomma alla prossima revisione mi converrà ripensare tutto!

ho capito , ma penso non mi servira' altro
ora posso ordinare e ricercare CD e Film

grazie